home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / boot / perv.sml < prev    next >
Encoding:
Text File  |  1993-02-15  |  83.9 KB  |  2,600 lines

  1. (* Copyright 1989, 1990, 1991, 1992 by AT&T Bell Laboratories *)
  2.  
  3. structure Initial =
  4. struct
  5.  
  6. (* Define the List, System, IO, Bool, String and ByteArray structures.
  7.    Do not signature match the ByteArray and String structures, to 
  8.    preserve the inline properties of String.ordof, ByteArray.update,
  9.    and ByteArray.sub *)
  10.  
  11. local
  12. open Core
  13.  
  14. (* create a type-safe version of the InLine structure while preserving
  15.    the inline property of the functions. *)
  16. structure InLine =
  17. struct
  18.   infix 7 * div
  19.   infix 6 + -
  20.   infix 4 < > <= >=
  21.   infix 3 :=
  22.   val capture : ('1a cont -> '1a) -> '1a = InLine.capture
  23.   val callcc : ('1a cont -> '1a) -> '1a = InLine.callcc
  24.   val throw : 'a cont -> 'a -> 'b = InLine.throw
  25.   val ! : 'a ref -> 'a = InLine.!
  26.   val op * : int * int -> int = InLine.*
  27.   val op + : int * int -> int = InLine.+
  28.   val op - : int * int -> int = InLine.-
  29.   val op := : 'a ref * 'a -> unit = InLine.:=
  30.   val op < : int * int -> bool = InLine.<
  31.   val op <= : int * int -> bool = InLine.<=
  32.   val op > : int * int -> bool = InLine.>
  33.   val op >= : int * int -> bool = InLine.>=
  34.   val lessu : int * int -> bool = InLine.lessu
  35.   val gequ : int * int -> bool = InLine.gequ
  36.   val alength : 'a array -> int = InLine.length
  37.   val boxed : 'a -> bool = InLine.boxed
  38.   val unboxed : 'a -> bool = InLine.unboxed
  39.   val cast : 'a -> 'b = InLine.cast
  40.   val op div : int * int -> int = InLine.div
  41.   val fadd : real * real -> real = InLine.fadd
  42.   val fdiv : real * real -> real = InLine.fdiv
  43.   val feql : real * real -> bool = InLine.feql
  44.   val fge : real * real -> bool = InLine.fge
  45.   val fgt : real * real -> bool = InLine.fgt
  46.   val fle : real * real -> bool = InLine.fle
  47.   val flt : real * real -> bool = InLine.flt
  48.   val fmul : real * real -> real = InLine.fmul
  49.   val fneq : real * real -> bool = InLine.fneq
  50.   val fsub : real * real -> real = InLine.fsub
  51.   val fnegd : real -> real = InLine.fnegd
  52.   val fabsd : real -> real = InLine.fabsd
  53.   val ieql : int * int -> bool = InLine.ieql
  54.   val ineq : int * int -> bool = InLine.ineq
  55.   val makeref : 'a -> 'a ref = InLine.makeref
  56.   val ordof : string * int -> int = InLine.ordof
  57.   val slength : string -> int = InLine.length
  58.   val objlength : 'a -> int = InLine.objlength
  59.   val store : string * int * int -> unit = InLine.store
  60.   val byteof : Assembly.A.bytearray * int -> int = InLine.ordof
  61.   val blength : Assembly.A.bytearray -> int = InLine.length
  62.   val bstore : Assembly.A.bytearray * int * int -> unit = InLine.store
  63.   val subscript : 'a array * int -> 'a = InLine.subscript
  64.   val update : 'a array * int * 'a -> unit = InLine.update
  65.   val inlsubscript : 'a array * int -> 'a = InLine.inlsubscript
  66.   val inlupdate : 'a array * int * 'a -> unit = InLine.inlupdate
  67.   val inlbyteof : Assembly.A.bytearray * int -> int = InLine.inlbyteof
  68.   val inlbstore : Assembly.A.bytearray * int * int -> unit = InLine.inlstore
  69.   val inlordof: string * int -> int = InLine.inlordof
  70.   val    ~ : int -> int = InLine.~
  71.   val reql : 'a ref * 'a ref -> bool = InLine.ieql
  72.   val aeql : 'a array * 'a array -> bool = InLine.ieql
  73. (*
  74.   val floor : real -> int = InLine.floor
  75.   val round : real -> int = InLine.round
  76. *)
  77.   val real: int -> real = InLine.real   
  78.   val subscriptf : Assembly.A.realarray * int -> real = InLine.subscriptf
  79.   val updatef : Assembly.A.realarray * int * real -> unit = InLine.updatef
  80.   val inlsubscriptf : Assembly.A.realarray * int -> real = InLine.inlsubscriptf
  81.   val inlupdatef : Assembly.A.realarray * int * real -> unit = InLine.updatef
  82.   val subscriptv : 'a vector * int -> 'a = InLine.subscriptv
  83.   val andb : int * int -> int = InLine.andb
  84.   val orb : int * int -> int = InLine.orb
  85.   val xorb : int * int -> int = InLine.xorb
  86.   val rshift : int * int -> int = InLine.rshift
  87.   val lshift : int * int -> int = InLine.lshift
  88.   val notb : int -> int = InLine.notb
  89.   val gettag : 'a -> int = InLine.gettag
  90.   val mkspecial : int * 'a -> 'b = InLine.mkspecial
  91.   val getspecial : 'a -> int = InLine.getspecial
  92.   val setspecial : ('a * int) -> unit = InLine.setspecial
  93.   val getvar : unit -> 'a = InLine.getvar
  94.   val setvar : 'a -> unit = InLine.setvar
  95.   val gethdlr : unit -> 'a = InLine.gethdlr
  96.   val sethdlr : 'a -> unit = InLine.sethdlr
  97. end  (* structure InLine *)
  98.  
  99. structure Hooks =
  100. struct
  101.   structure Assembly=Assembly
  102.   local open InLine in
  103.   exception UNDEFINED
  104.   val defaultFn = fn _ => raise UNDEFINED
  105.  
  106.   val valSymbol_ref : (unit -> unit) ref = ref defaultFn
  107.   val tycSymbol_ref : (unit -> unit) ref = ref defaultFn
  108.   val sigSymbol_ref : (unit -> unit) ref = ref defaultFn
  109.   val strSymbol_ref : (unit -> unit) ref = ref defaultFn
  110.   val fctSymbol_ref : (unit -> unit) ref = ref defaultFn
  111.   val fixSymbol_ref : (unit -> unit) ref = ref defaultFn
  112.   val labSymbol_ref : (unit -> unit) ref = ref defaultFn
  113.   val tyvSymbol_ref : (unit -> unit) ref = ref defaultFn
  114.   val fsigSymbol_ref: (unit -> unit) ref = ref defaultFn
  115.   val name_ref      : (unit -> unit) ref = ref defaultFn
  116.   val makestring_ref: (unit -> unit) ref = ref defaultFn
  117.   val kind_ref      : (unit -> unit) ref = ref defaultFn
  118.   val nameSpace_ref : (unit -> unit) ref = ref defaultFn
  119.  
  120.   val emptyEnv_ref     : (unit -> unit) ref = ref defaultFn
  121.   val concatEnv_ref    : (unit -> unit) ref = ref defaultFn
  122.   val layerEnv_ref     : (unit -> unit) ref = ref defaultFn
  123.   val staticPart_ref   : (unit -> unit) ref = ref defaultFn
  124.   val layerStatic_ref  : (unit -> unit) ref = ref defaultFn
  125.   val filterEnv_ref    : (unit -> unit) ref = ref defaultFn
  126.   val filterStaticEnv_ref
  127.                : (unit -> unit) ref = ref defaultFn
  128.   val catalogEnv_ref   : (unit -> unit) ref = ref defaultFn
  129.   val describe_ref     : (unit -> unit) ref = ref defaultFn
  130.  
  131.   val makeSource_ref  : (unit -> unit) ref = ref defaultFn
  132.   val closeSource_ref : (unit -> unit) ref = ref defaultFn
  133.   val changeLvars_ref : (unit -> unit) ref = ref defaultFn
  134.   val elaborate_ref   : (unit -> unit) ref = ref defaultFn
  135.   val parse_ref       : (unit -> unit) ref = ref defaultFn
  136.   val compile_ref     : (unit -> unit) ref = ref defaultFn
  137.   val compileAst_ref  : (unit -> unit) ref = ref defaultFn
  138.   val execute_ref     : (unit -> unit) ref = ref defaultFn
  139.   val eval_stream_ref : (unit -> unit) ref = ref defaultFn
  140.   val use_file_ref    : (unit -> unit) ref = ref defaultFn
  141.   val use_stream_ref  : (unit -> unit) ref = ref defaultFn
  142.  
  143.   val allocProfReset_ref : (unit -> unit) ref = ref defaultFn
  144.   val allocProfPrint_ref : (unit -> unit) ref = ref defaultFn
  145.  
  146.   val mk_ppstream_ref : (unit -> unit) ref = ref defaultFn
  147.   val dest_ppstream_ref : (unit -> unit) ref = ref defaultFn
  148.   val begin_block_ref : (unit -> unit) ref = ref defaultFn
  149.   val end_block_ref   : (unit -> unit) ref = ref defaultFn
  150.   val add_break_ref   : (unit -> unit) ref = ref defaultFn
  151.   val add_string_ref  : (unit -> unit) ref = ref defaultFn
  152.   val add_newline_ref : (unit -> unit) ref = ref defaultFn
  153.   val clear_ppstream_ref    : (unit -> unit) ref = ref defaultFn
  154.   val flush_ppstream_ref : (unit -> unit) ref = ref defaultFn
  155.   val with_pp_ref  : (unit -> unit) ref = ref defaultFn
  156.   val install_pp_ref  : (unit -> unit) ref = ref defaultFn
  157.  
  158.   val prLambda        : (unit -> unit) ref = ref defaultFn
  159.   val debugInterface  : (int -> unit) ref = ref defaultFn
  160.   val lookup_r : (int-> Assembly.object) ref= ref defaultFn
  161.  
  162.   val defaultCont : unit cont = InLine.callcc(fn k1 => (InLine.callcc(fn k2 => 
  163.                           (InLine.throw k1 k2));
  164.                      raise UNDEFINED))
  165.   val profile_register : (string -> int * int array * int ref) ref = profile_register
  166.   val toplevelcont = ref defaultCont
  167.   val profile_sregister : (Assembly.object * string -> Assembly.object) ref = 
  168.        profile_sregister
  169.  
  170.   val pervasiveEnvRef : Assembly.object ref = InLine.cast(ref (nil,nil,nil))
  171.       (* NOTE: This "nil,nil,nil" simulates three different constant
  172.        "EMPTY" constructors with the same representation. *)
  173.   val topLevelEnvRef : Assembly.object ref = InLine.cast(ref (nil,nil,nil))
  174.  
  175.   fun clear () =
  176.       (
  177.        valSymbol_ref := defaultFn;
  178.        tycSymbol_ref := defaultFn;
  179.        sigSymbol_ref := defaultFn;
  180.        strSymbol_ref := defaultFn;
  181.        fctSymbol_ref := defaultFn;
  182.        fixSymbol_ref := defaultFn;
  183.        labSymbol_ref := defaultFn;
  184.        tyvSymbol_ref := defaultFn;
  185.        fsigSymbol_ref := defaultFn;
  186.        name_ref := defaultFn;
  187.        makestring_ref := defaultFn;
  188.        kind_ref := defaultFn;
  189.        nameSpace_ref := defaultFn;
  190.  
  191.        emptyEnv_ref := defaultFn;
  192.        concatEnv_ref := defaultFn;
  193.        layerEnv_ref := defaultFn;
  194.        staticPart_ref := defaultFn;
  195.        layerStatic_ref := defaultFn;
  196.        filterEnv_ref := defaultFn;
  197.        filterStaticEnv_ref := defaultFn;
  198.        catalogEnv_ref := defaultFn;
  199.        describe_ref := defaultFn;
  200.  
  201.        makeSource_ref := defaultFn;
  202.        closeSource_ref := defaultFn;
  203.        changeLvars_ref := defaultFn;
  204.        elaborate_ref := defaultFn;
  205.        parse_ref := defaultFn;
  206.        compile_ref := defaultFn;
  207.        compileAst_ref := defaultFn;
  208.        execute_ref  := defaultFn;
  209.        eval_stream_ref := defaultFn;
  210.        use_file_ref := defaultFn;
  211.        use_stream_ref := defaultFn;
  212.  
  213.        mk_ppstream_ref := defaultFn;
  214.        dest_ppstream_ref := defaultFn;
  215.        begin_block_ref := defaultFn;
  216.        end_block_ref := defaultFn;
  217.        add_break_ref := defaultFn;
  218.        add_string_ref := defaultFn;
  219.        add_newline_ref := defaultFn;
  220.        clear_ppstream_ref := defaultFn;
  221.        flush_ppstream_ref := defaultFn;
  222.        with_pp_ref := defaultFn;
  223.        install_pp_ref := defaultFn;
  224.  
  225.        prLambda := defaultFn;
  226.        debugInterface := defaultFn;
  227.        lookup_r := defaultFn;
  228.  
  229.        profile_register := defaultFn;
  230.        profile_sregister := defaultFn;
  231.        pervasiveEnvRef := InLine.cast (nil,nil,nil);
  232.        topLevelEnvRef := InLine.cast (nil,nil,nil);
  233.        toplevelcont := defaultCont;
  234.        Core.getDebugf := defaultFn;
  235.        Core.forcer_p := defaultFn;
  236.        Core.errorMatch := ""
  237.       )
  238.  
  239.   end (* local *)
  240. end (* structure Hooks *)
  241.  
  242.  
  243. structure Tags =
  244.   struct
  245.     datatype tag = TAG of int
  246.   (* taken from runtime/tags.h *)
  247.     val width_tags = 6  (* 4 tag bits plus "10" *)
  248.   (* one greater than the maximum length field value (sign should be 0) *)
  249.     val max_length = InLine.lshift(1, InLine.-(31,width_tags))
  250.     val power_tags = 0x40  (* 1 << 6 *)
  251.     fun tagWLen n = TAG(InLine.orb(0x22, InLine.lshift(n, 2)))
  252.     fun tagWOLen n = TAG(InLine.orb(0x02, InLine.lshift(n, 2)))
  253.     val tag_record        = tagWLen 0
  254.     val tag_array        = tagWLen 1
  255.     val tag_string        = tagWLen 2
  256.     val tag_embedded_string    = tagWLen 3
  257.     val tag_bytearray        = tagWLen 4
  258.     val tag_realdarray        = tagWLen 5
  259.     val tag_pair        = tagWOLen 0
  260.     val tag_reald        = tagWOLen 1
  261.     val tag_embedded_reald    = tagWOLen 2
  262.     val tag_variant        = tagWOLen 3 (* currently not used *)
  263.     val tag_special        = tagWOLen 4
  264.     val tag_backptr        = tagWOLen 5
  265.   (* build a descriptor from a tag and length *)
  266.     fun make_desc (len, TAG t) = InLine.orb(InLine.lshift(len, width_tags), t)
  267.   (* fixed descriptors *)
  268.     val desc_pair = make_desc(2, tag_pair)
  269.     val desc_reald = make_desc(2, tag_reald)
  270.     val desc_embedded_reald = make_desc(2, tag_embedded_reald)
  271.   (* special descriptors *)
  272.     val desc_special = make_desc(0, tag_special)
  273.     val special_unevaled_susp    = 0
  274.     val special_evaled_susp    = 1
  275.     val special_weak        = 2
  276.     val special_nulled_weak    = 3
  277.   end (* structure Tags *)
  278.  
  279. (* The datatype ref is defined in the built-in structure PrimTypes.
  280.    It is not mention here because it has a unique representation; an
  281.    explicit datatype declaration would destroy this representation.
  282.    Similarly, there is no datatype specification in the REF signature
  283.    itself. *)
  284. structure Ref = 
  285. struct
  286.   infix 3 :=
  287.   val ! = InLine.!
  288.   val op := = InLine.:=
  289.   fun inc r = r := InLine.+(!r,1)
  290.   fun dec r = r := InLine.-(!r,1)
  291. end (* structure Ref *)
  292.  
  293. structure List : LIST =
  294. struct
  295.   infixr 5 :: @
  296.   open PrimTypes InLine
  297.   exception Hd
  298.   exception Tl
  299.   exception Nth
  300.   exception NthTail
  301.   fun hd (a::r) = a | hd nil = raise Hd
  302.   fun tl (a::r) = r | tl nil = raise Tl    
  303.   fun null nil = true | null _ = false
  304.   fun length l = 
  305.       let fun j(k,nil) = k
  306.         | j(k, a::x) = j(k+1,x)
  307.        in j(0,l)
  308.       end
  309.   fun op @(x,nil) = x
  310.     | op @(x,l) =
  311.     let fun f(nil,l) = l
  312.           | f([a],l) = a::l
  313.         | f([a,b],l) = a::b::l
  314.         | f([a,b,c],l) = a::b::c::l
  315.         | f(a::b::c::d::r,l) = a::b::c::d::f(r,l)
  316.      in f(x,l)
  317.     end
  318.   fun rev l =
  319.       let fun f (nil, h) = h
  320.         | f (a::r, h) = f(r, a::h)
  321.       in  f(l,nil)
  322.       end
  323.   fun map f =
  324.       let fun m nil = nil
  325.             | m [a] = [f a]
  326.             | m [a,b] = [f a, f b]
  327.             | m [a,b,c] = [f a, f b, f c]
  328.             | m (a::b::c::d::r) = f a :: f b :: f c :: f d :: m r
  329.       in  m
  330.       end
  331.   fun fold f [] = (fn b => b)
  332.     | fold f (a::r) = (fn b => let fun f2(e,[]) = f(e,b)
  333.                      | f2(e,a::r) = f(e,f2(a,r))
  334.                    in f2(a,r)
  335.                    end)
  336.   fun revfold f [] = (fn b => b)
  337.     | revfold f (a::r) = (fn b => let fun f2(e,[],b) = f(e,b)
  338.                     | f2(e,a::r,b) = f2(a,r,f(e,b))
  339.                   in f2(a,r,b)
  340.                   end)    
  341.   fun app f = let fun a2 (e::r) = (f e; a2 r) | a2 nil = () in a2 end
  342.   fun revapp f = let fun a2 (e::r) = (a2 r; f e; ()) | a2 nil = () in a2 end
  343.   fun nthtail(e,0) = e 
  344.     | nthtail(e::r,n) = nthtail(r,n-1)
  345.     | nthtail _ = raise NthTail
  346.   fun nth x = hd(nthtail x) handle NthTail => raise Nth | Hd => raise Nth
  347.   fun exists pred =
  348.       let fun f nil = false
  349.         | f (hd::tl) = pred hd orelse f tl
  350.       in  f
  351.       end
  352. end (* structure List *)
  353.  
  354. structure PreString : sig exception Substring
  355.               val substring : string * int * int -> string
  356.               val ^ : string * string -> string
  357.               val imakestring : int -> string
  358.                           val implode: string list -> string
  359.               end =
  360. struct
  361.   open InLine
  362.   exception Substring
  363.   fun substring("",0,0) = "" (* never call create_s with 0 *)
  364.     | substring("",_,_) = raise Substring
  365.     | substring(s,i,0) = if i>=0 
  366.               then if boxed s then if i <= slength s
  367.                            then "" else raise Substring
  368.                       else if i<=1 
  369.                            then "" else raise Substring
  370.               else raise Substring
  371.     | substring(s,0,1) = if boxed s then cast(ordof(s,0)) else s
  372.     | substring(s,i,1) =
  373.        if boxed s then if i>=0 andalso i < slength s 
  374.                   then cast(ordof(s,i))
  375.                   else raise Substring
  376.               else if ieql(i,0) then s else raise Substring
  377.     | substring(s,i,len) = 
  378.     if boxed s andalso i>=0 andalso i+len <= slength s
  379.           andalso len >= 0
  380.     then let val a = Assembly.A.create_s(len)
  381.          fun copy j = if ieql(j,len) then ()
  382.                   else (store(a,j,ordof(s,i+j)); copy(j+1))
  383.          in  copy 0; a
  384.          end
  385.     else raise Substring
  386.  
  387.   infix 6 ^
  388.   fun op ^ ("",s) = s
  389.     | op ^ (s,"") = s
  390.     | op ^ (x,y) =
  391.     if boxed x 
  392.     then if boxed y
  393.          then let val xl = slength x and yl = slength y
  394.               val a = Assembly.A.create_s(xl+yl)
  395.               fun copyx n = if ieql(n,xl) then ()
  396.                 else (store(a,n,ordof(x,n)); copyx(n+1))
  397.               fun copyy n = if ieql(n,yl) then ()
  398.                 else (store(a,xl+n,ordof(y,n)); copyy(n+1))
  399.            in copyx 0; copyy 0; a
  400.           end
  401.         else let val xl = slength x
  402.              val a = Assembly.A.create_s(xl+1)
  403.               fun copyx n = if ieql(n,xl) then ()
  404.                 else (store(a,n,ordof(x,n)); copyx(n+1))
  405.           in copyx 0; store(a,xl,cast y); a
  406.          end
  407.     else if boxed y               
  408.          then let val yl = slength y
  409.               val a = Assembly.A.create_s(1+yl)
  410.               fun copyy n = if ieql(n,yl) then ()
  411.                 else (store(a,1+n,ordof(y,n)); copyy(n+1))
  412.            in store(a,0,cast x); copyy 0; a
  413.           end
  414.         else let val a = Assembly.A.create_s 2
  415.           in store(a,0,cast x); store(a,1,cast y); a
  416.          end
  417.   fun imakestring i =
  418.     if i<0 then "~" ^ imakestring(~i)
  419.     else if i<10 then InLine.cast(InLine.cast "0" + i)
  420.     else let val j = i div 10
  421.          in  imakestring j ^ imakestring(i-j*10)
  422.          end
  423.  
  424.   fun length s = if boxed s then slength s else 1
  425.   val ordof = InLine.inlordof
  426.   fun implode (sl:string list) =
  427.       let val len = List.fold(fn(s,l) => length s + l) sl 0
  428.       in  case len
  429.            of 0 => ""
  430.             | 1 => let fun find (""::tl) = find tl
  431.                          | find (hd::_) = cast hd
  432.                          | find nil = "" (* impossible *)
  433.                    in  find sl
  434.                    end
  435.             | _ => let val new = Assembly.A.create_s len
  436.                        fun copy (nil,_) = ()
  437.                          | copy (s::tl,base) =
  438.                             let val len = length s
  439.                                 fun copy0 0 = ()
  440.                                   | copy0 i =
  441.                                     let val next = i-1
  442.                                     in  store(new,base+next,ordof(s,next));
  443.                                         copy0 next
  444.                                     end
  445.                             in  copy0 len;
  446.                                 copy(tl,base+len)
  447.                             end
  448.                     in  copy(sl,0);
  449.                         new
  450.                     end
  451.       end
  452. end (* structure PreString *)       
  453.  
  454. (*abstraction ByteArray : BYTEARRAY = *)
  455. structure ByteArray (* : BYTEARRAY*) =
  456. struct
  457.  local open InLine PreString in
  458.   infix 3 sub
  459.   type bytearray = Assembly.A.bytearray
  460.   exception Subscript = Core.Ord
  461.   exception Range = Core.Range
  462.   exception Size
  463.   val length = blength
  464.   fun array(len,v) =
  465.       if gequ(len,Tags.max_length)  (* catch negative-length arrays,
  466.                     and arrays with a size too big to fit
  467.                     in the descriptor *)
  468.       then raise Size
  469.       else if v<0 orelse v>=256 then raise Range
  470.       else if ieql(len,0) then Assembly.bytearray0
  471.       else let val a = Assembly.A.create_b len
  472.            fun init i = if ieql(i,len) then ()
  473.                 else (bstore(a,i,v); init(i+1))
  474.         in init 0; a
  475.        end
  476.   val update = InLine.inlbstore
  477.   val op sub = InLine.inlbyteof
  478. (*
  479.   fun update(arg as (s,i,c)) =
  480.       if i<0 orelse i >= length s then raise Subscript
  481.       else if c<0 orelse c>255 then raise Range
  482.       else bstore arg
  483.   val op sub = fn (s, i) =>
  484.     if lessu(i, length s) then byteof(s, i) else raise Subscript
  485. *)
  486.   fun extract(ba,i,1) =
  487.     if lessu(i, length ba) then cast(byteof(ba, i)) else raise Subscript
  488.     | extract(ba,i,len) = 
  489.     if i<0 orelse i+len > length ba orelse len<0 then raise Subscript
  490.     else if ieql(len,0) then ""
  491.     else let val a = Assembly.A.create_s len
  492.          fun copy j =  if ieql(j,len) then ()
  493.                    else (store(a,j,byteof(ba,i+j)); copy(j+1))
  494.          in  copy 0; a
  495.          end
  496.   fun app f ba = 
  497.       let val len = length ba
  498.       fun app' i = if i >= len then ()
  499.                else (f(ba sub i); app'(i+1))
  500.       in  app' 0
  501.       end
  502.   fun revapp f ba = 
  503.       let fun revapp' i = if i < 0 then ()
  504.               else (f(ba sub i); revapp'(i-1))
  505.       in  revapp'(length ba - 1)
  506.       end
  507.   fun fold f ba x = 
  508.       let fun fold'(i,x) = if i < 0 then x else fold'(i-1, f(byteof(ba,i),x))
  509.       in  fold'(length ba - 1, x)
  510.       end
  511.   fun revfold f ba x = 
  512.       let val len = length ba
  513.       fun revfold'(i,x) = if i >= len then x
  514.                   else revfold'(i+1,f(byteof(ba,i),x))
  515.       in  revfold'(0,x)
  516.       end
  517.  end (*local*)
  518. end (* abstraction ByteArray *)
  519.  
  520. structure PreLim =
  521. struct
  522.   local open InLine Tags
  523.         val string_tag = make_desc(0,tag_string)
  524.         val embedded_string_tag = make_desc(0,tag_embedded_string)
  525.     (* Normal exception names are strings; debugger exception names
  526.        are pairs of the form string * int. *)
  527.     fun normalExnName (x:Assembly.object) : bool = 
  528.              if boxed x then 
  529.             let val tag = gettag x 
  530.             in ieql(tag,string_tag) orelse 
  531.                ieql(tag,embedded_string_tag)
  532.             end
  533.          else true
  534.   in
  535.     val exn_name : exn -> string = 
  536.                  cast(fn(ref s,_) => 
  537.              if normalExnName (cast s)
  538.              then s 
  539.              else let val (s,_) = cast s
  540.               in s
  541.               end)
  542.   end
  543.   val interactive = ref true
  544.   val prLambda = Hooks.prLambda
  545. end (* structure PreLim *)
  546.  
  547. structure Time =
  548. struct
  549.   datatype time = TIME of {sec : int, usec : int}    
  550. end (* Time *)
  551.  
  552. structure PreStats =
  553. struct
  554.   open Time
  555.  local open Assembly.A Ref in
  556.   val zerotime = TIME{sec=0,usec=0}
  557.   val lines = ref 0
  558.   val parse = ref zerotime
  559.   val debuginstrum = ref zerotime
  560.   val translate = ref zerotime
  561.   val codeopt = ref zerotime
  562.   val convert = ref zerotime
  563.   val hoist = ref zerotime
  564.   val cpsopt = ref zerotime
  565.   val closure = ref zerotime
  566.   val globalfix = ref zerotime
  567.   val spill = ref zerotime
  568.   val codegen = ref zerotime
  569.   val schedule = ref zerotime
  570.   val freemap = ref zerotime
  571.   val execution = ref zerotime
  572.   val codesize = ref 0
  573.   fun reset() = 
  574.       (lines := 0;
  575.        parse := zerotime;
  576.        debuginstrum := zerotime;
  577.        translate := zerotime;
  578.        codeopt := zerotime;
  579.        convert := zerotime;
  580.        cpsopt := zerotime;
  581.        closure := zerotime;
  582.        globalfix := zerotime;
  583.        spill := zerotime;
  584.        codegen := zerotime;
  585.        schedule := zerotime;
  586.        freemap := zerotime;
  587.        execution := zerotime;
  588.        codesize := 0)
  589.  end (* local *)
  590. end  (* PreStats *)
  591.  
  592. structure CInterface =
  593. struct
  594.   open Time
  595.  
  596.   exception CFunNotFound of string
  597.  
  598.   fun c_function s = let
  599.     fun f (Assembly.FUNC(p,t,rest)) = if stringequal(s,t) then p else (f rest)
  600.       | f Assembly.FUNCNIL = raise (CFunNotFound s)
  601.     val cfun = f Assembly.external
  602.     in
  603.       fn x => (Assembly.A.callc (cfun, x))
  604.     end
  605.  
  606. (* zero pad a string to make it acceptable to C; two zeros are required in
  607.  * case s is a null string. *)
  608.   fun c_string s = PreString.^(s, "\000\000")
  609.  
  610. (* type-safe interface to the C functions *)
  611.   val argv        : unit -> string list = c_function "argv"
  612.   val environ        : unit -> string list = c_function "environ"
  613.   val gethostname   : unit -> string = c_function "gethostname"
  614.   val exec        : (string * string list * string list) -> (int * int) =
  615.     c_function "exec"
  616.   val system        : string -> int = c_function "system"
  617.   val export        : int -> bool = c_function "export"
  618.   val blas        : (int * 'a) -> int = c_function "blas"
  619.   val salb        : string -> 'a = c_function "salb"
  620.   val gc        : int -> unit = c_function "gc"
  621.   val gethostid     : unit -> string = c_function "gethostid"
  622.  
  623.   local
  624.     val gettime' : unit -> (int * int * int * int * int * int) =
  625.       c_function "gettime"
  626.   in
  627.   fun gettime () = let val (ts, tu, ss, su, gs, gu) = gettime' ()
  628.     in {
  629.       usr=TIME{sec=ts, usec=tu},
  630.       sys=TIME{sec=ss, usec=su},
  631.       gc=TIME{sec=gs, usec=gu}
  632.     } end
  633.   end (* local *)
  634.  
  635.   local
  636.     val setitimer' : (int * int * int * int * int) -> unit = c_function "setitimer"
  637.   in
  638.     fun setitimer (which, TIME{sec=s1, usec=u1}, TIME{sec=s2, usec=u2}) =
  639.       setitimer' (which, s1, u1, s2, u2)
  640.   end (* local *)
  641.  
  642.   local
  643.     val gettimeofday' : unit -> (int * int) = c_function "timeofday"
  644.   in
  645.     fun gettimeofday () = let
  646.       val (ts,tu) = gettimeofday' ()
  647.     in
  648.       TIME{sec=ts, usec=tu}
  649.     end
  650.   end (* local *)
  651.  
  652. (* type-safe interface to some system calls *)
  653.   val syscall        : (int * string list) -> int = c_function "syscall"
  654.   exception SystemCall of string
  655.   exception SysError = Assembly.SysError
  656.  
  657.   val exit : int -> 'a = c_function "exit"
  658.   val chdir = let val cd : string -> unit = c_function "chdir"
  659.     in
  660.       fn s => cd(c_string s)
  661.     end
  662.   val getpid : unit -> int = c_function "getpid"
  663.   val getuid : unit -> int = c_function "getuid"
  664.   val getgid : unit -> int = c_function "getgid"
  665.  
  666.   local open PreString in
  667.   fun wrap_sysfn name f x = (f x)
  668.     handle SysError(_, s) => raise (SystemCall(name ^ " failed, " ^ s))
  669.   end
  670. end (* structure CInterface *)
  671.  
  672. structure SysIO =
  673. struct
  674.   type bytearray = ByteArray.bytearray
  675.   open Time
  676.  
  677.   type fd = int
  678.   type fileid = string
  679.   datatype fname    = DESC of fd | PATH of string
  680.   datatype mode        = O_READ | O_WRITE | O_APPEND
  681.   datatype whence    = L_SET | L_INCR | L_XTND
  682.   datatype access    = A_READ | A_WRITE | A_EXEC
  683.   datatype file_type    = F_REGULAR | F_DIR | F_SYMLINK | F_SOCK | F_CHR | F_BLK
  684.  
  685.   local
  686.     open CInterface InLine
  687.     fun sysfn name = (wrap_sysfn name (c_function name))
  688.     fun fileOf (DESC fd) = (cast fd)
  689.       | fileOf (PATH s) = (c_string s)
  690.     infix 3 o
  691.     fun f o g = (fn x => f(g x))
  692.   in
  693.  
  694.   val dtablesize = Assembly.dtablesize;
  695.  
  696.   local
  697.     val openf' : (string * int) -> fd = sysfn "openf"
  698.   in
  699.   fun openf (path, mode) = let
  700.     val flag = case mode of O_READ => 0 | O_WRITE => 1 | O_APPEND => 2
  701.     in
  702.         openf' (c_string path, flag)
  703.     end
  704.   end (* local *)
  705.  
  706.   val closef : fd -> unit = sysfn "closef"
  707.   val unlink : string -> unit = (sysfn "unlink") o c_string
  708.   val mkdir = let
  709.     val mk : (string * int) -> unit = sysfn "mkdir"
  710.     in
  711.       fn (s, i) => mk(c_string s, i)
  712.     end
  713.   val dup : fd -> fd = sysfn "dup"
  714.  
  715.   val pipe          : unit -> (int * int) = sysfn "pipe"
  716.   val connect_unix  : string -> fd = (sysfn "connect_unix") o c_string
  717.   val connect_inet  : (string * string) -> fd = let
  718.     val f = sysfn "connect_inet"
  719.     in
  720.       fn (s1, s2) => f(c_string s1, c_string s2)
  721.     end
  722.  
  723.   val read      : (fd * bytearray * int) -> int = sysfn "read"
  724.   val readi      : (fd * bytearray * int * int) -> int = sysfn "readi"
  725.   val write      : (fd * bytearray * int) -> unit = sysfn "write"
  726.   val writei      : (fd * bytearray * int * int) -> unit = sysfn "writei"
  727.   val writev      : (fd * (bytearray * int) list) -> unit = sysfn "writev"
  728.   val send_obd  : (fd * bytearray * int) -> unit = sysfn "send_obd"
  729.   val getdirent : fd -> string list = sysfn "getdirent"
  730.   val readlink  : string -> string = (sysfn "readlink") o c_string
  731.  
  732.   local
  733.     val link' : (bool * string * string) -> unit = (c_function "link")
  734.   in
  735.   val link = wrap_sysfn "link"
  736.           (fn (name, lname) => link'(false, c_string name, c_string lname))
  737.   val symlink = wrap_sysfn "symlink"
  738.           (fn (name, lname) => link'(true, c_string name, c_string lname))
  739.   end
  740.  
  741.   local
  742.     val truncate' : (string * int) -> unit = sysfn "truncate"
  743.   in
  744.   fun truncate (f, len) = truncate'(fileOf f, len)
  745.   end
  746.  
  747.   local
  748.     val lseek' : int * int * int -> int = sysfn "lseek"
  749.   in
  750.     fun lseek (d, off, whence) = let
  751.       val w = case whence of L_SET => 0 | L_INCR => 1 | L_XTND => 2
  752.       in
  753.         lseek' (d, off, w)
  754.       end
  755.   end
  756.  
  757.   local
  758.     val chmod' : (string * int) -> unit = sysfn "chmod"
  759.   in
  760.   fun chmod (f, m) = chmod'(fileOf f, m)
  761.   end
  762.  
  763.   local
  764.     val access' : (string * int list) -> bool = sysfn "access"
  765.     val map_mode = List.map (fn A_READ => 0 | A_WRITE => 1 | A_EXEC => 2)
  766.   in
  767.   fun access (path, alist) = access' (c_string path, map_mode alist)
  768.   end (* local *)
  769.  
  770.   val umask : int -> int = sysfn "umask"
  771.  
  772.   local
  773.     val ftype' : string -> int = (sysfn "ftype")
  774.   in
  775.   fun ftype f = case (ftype' (fileOf f))
  776.      of 0 => F_REGULAR | 1 => F_DIR | 2 => F_SYMLINK
  777.       | 3 => F_SOCK | 4 => F_CHR | 5 => F_BLK
  778.   end (* local val ftype' *)
  779.  
  780.   val getfid      : fname -> fileid        = sysfn "getfid" o fileOf
  781.   val getmod      : fname -> int        = sysfn "getmod" o fileOf
  782.   val isatty      : int -> bool                = sysfn "isatty"
  783.   val fionread    : int -> int                = sysfn "fionread"
  784.   val getownid    : fname -> (int * int)    = (sysfn "getownid") o fileOf
  785.   val fsize      : fname -> int        = (sysfn "fsize") o fileOf
  786.   local
  787.     fun fileTime f s = let val (s, u) = f (fileOf s) in TIME{sec=s, usec=u} end
  788.   in
  789.   val atime        : fname -> time        = fileTime (sysfn "atime")
  790.   val ctime        : fname -> time        = fileTime (sysfn "ctime")
  791.   val mtime        : fname -> time        = fileTime (sysfn "mtime")
  792.   end
  793.  
  794.   local
  795.     val select' : (int list * int list * int list * (int * int))
  796.             -> (int list * int list * int list) = (sysfn "select")
  797.   in
  798.   fun select (rfds, wfds, efds, t) = let
  799.     val timeout =
  800.           case t of NONE => (cast 0) | SOME(TIME{sec, usec}) => (sec, usec)
  801.     in
  802.       select' (rfds, wfds, efds, timeout)
  803.     end
  804.   end (* local val select' *)
  805.   end (* local *)
  806. end (* SysIO *)
  807.  
  808.  
  809. structure CleanUp =
  810. struct
  811.   datatype clean_mode
  812.     = CleanForExportML | CleanForExportFn | CleanForQuit | CleanForInit
  813.  
  814.   local
  815.     open Ref List
  816.     val cleaners = ref ([] : (string * (clean_mode -> unit)) list)
  817.   in
  818.  
  819. (* add the named cleaner, replacing the previous definition if necessary *)
  820.   fun addCleaner (arg as (name, _)) = let
  821.     fun add ((x as (s, _))::r) = if (stringequal(name, s))
  822.           then arg::r
  823.           else (x::(add r))
  824.     val (newlist, res) = (add(!cleaners), false)
  825.                 handle Match => (arg::(!cleaners), true)
  826.     in
  827.       cleaners := newlist; res
  828.     end
  829. (* remove the named cleaner; raise Match is not found *)
  830.   fun removeCleaner name = let
  831.     fun remove ((x as (s, _))::r) = if (stringequal(name, s))
  832.           then r
  833.           else x::(remove r)
  834.     in
  835.       cleaners := remove(!cleaners)
  836.     end
  837. (* apply the list of cleaners *)
  838.   fun cleanup mode =
  839.     app (fn (_, f) => ((f mode) handle _ => ())) (!cleaners)
  840. (* shutdown with cleanup *)
  841.   fun shutdown () = (cleanup CleanForQuit; CInterface.exit 0)
  842.  
  843.   end (* local *)
  844. end (* CleanUp *)
  845.  
  846. structure Signals : SIGNALS = 
  847. struct
  848.   local open Ref in
  849.  
  850.   val nsigs = 16
  851.  
  852.   datatype signal
  853.     = SIGHUP | SIGINT | SIGQUIT | SIGVTALRM | SIGALRM | SIGTERM | SIGURG
  854.     | SIGCHLD | SIGIO | SIGWINCH | SIGUSR1 | SIGUSR2 | SIGPROF
  855.     | SIGTSTP | SIGCONT (* not yet supported *)
  856.     | SIGGC
  857.  
  858.   datatype sig_sts
  859.     = ENABLED of ((int * unit cont) -> unit cont)
  860.     | DISABLED
  861.  
  862.   val sigvec = Assembly.A.array(nsigs, DISABLED)
  863.  
  864. (* sigHandler : (int * int * unit cont) -> unit cont
  865.  * This is the root ML signal handler
  866.  *)
  867.   fun sigHandler (code, count, resume_k) = (
  868.     case (InLine.subscript(sigvec, code))
  869.      of DISABLED => resume_k
  870.       | (ENABLED handler) => handler (count, resume_k))
  871.  
  872. (* Install the root handler *)
  873.   val _ = (Assembly.sighandler := sigHandler)
  874.  
  875.   exception UnimplementedSignal
  876.  
  877. (* convert SML signal names to run-time signal codes.  these must
  878.  * agree with the codes in "runtime/ml_signal.h"
  879.  *)
  880.   fun sig2code SIGHUP        = 0
  881.     | sig2code SIGINT        = 1
  882.     | sig2code SIGQUIT    = 2
  883.     | sig2code SIGALRM    = 3
  884.     | sig2code SIGTERM    = 4
  885.     | sig2code SIGURG        = 5
  886.     | sig2code SIGCHLD    = 6
  887.     | sig2code SIGIO        = 7
  888.     | sig2code SIGWINCH   = 8
  889.     | sig2code SIGUSR1    = 9
  890.     | sig2code SIGUSR2    = 10
  891.     | sig2code SIGTSTP    = (* 11 *) raise UnimplementedSignal
  892.     | sig2code SIGCONT    = (* 12 *) raise UnimplementedSignal
  893.     | sig2code SIGGC        = 13
  894.     | sig2code SIGVTALRM    = 14
  895.     | sig2code SIGPROF      = (* 15 *) raise UnimplementedSignal
  896.     
  897.  
  898. (* signal masking *)
  899.   local
  900.     val maskSigs : bool -> unit = CInterface.c_function "masksigs"
  901.     val maskLevel = ref 0
  902.   in
  903.     fun maskSignals true = (
  904.       case (!maskLevel)
  905.        of 0 => (maskSigs true; maskLevel := 1)
  906.         | n => (maskLevel := InLine.+(n, 1)))
  907.       | maskSignals false = (
  908.       case (!maskLevel)
  909.        of 0 => ()
  910.         | 1 => (maskLevel := 0; maskSigs false)
  911.         | n => (maskLevel := InLine.-(n, 1)))
  912.     fun masked () = (InLine.>(!maskLevel, 0))
  913.   end (* local *)
  914.  
  915.   val enableSig : (int * bool) -> unit = CInterface.c_function "enablesig"
  916.  
  917.   fun setHandler (signal, newHandler) = let
  918.     val code = sig2code signal
  919.     in
  920.       maskSignals true;
  921.       case (newHandler, InLine.subscript(sigvec, code))
  922.        of (SOME h, DISABLED) => (
  923.         InLine.update (sigvec, code, ENABLED h);
  924.         enableSig(code, true))
  925.         | (SOME h, _) => InLine.update (sigvec, code, ENABLED h)
  926.         | (NONE, ENABLED _) => (
  927.         enableSig (code, false);
  928.         InLine.update (sigvec, code, DISABLED))
  929.         | _ => ()
  930.       (* end case *);
  931.       maskSignals false
  932.     end
  933.  
  934.   fun inqHandler signal = (
  935.     case (InLine.subscript(sigvec, sig2code signal))
  936.      of DISABLED => NONE
  937.       | (ENABLED handler) => SOME handler)
  938.  
  939. (* sleep until the next signal (sigpause(2)) *)
  940.   val pause : unit -> unit = CInterface.c_function "sigpause"
  941.  
  942.   end (* local open *)
  943. end (* Signals *)
  944.  
  945. (* Buffered I/O module.  In order to preserve the consistency of the buffers,
  946.  * a number of operations must be done with signals masked.
  947.  *)
  948. structure PreIO = 
  949. struct
  950.   exception Io of string
  951.   local
  952.     open InLine Ref PreString PrimTypes CInterface SysIO CleanUp
  953.     val charOf : (ByteArray.bytearray * int) -> string = cast byteof
  954.     type bytearray = ByteArray.bytearray
  955.     val bufsize = 1024
  956.     val close = wrap_sysfn "close" closef
  957.     val pipe = wrap_sysfn "pipe" pipe
  958.     fun error (cmd, name, s) = raise Io(cmd ^ " \"" ^ name ^ "\": " ^ s)
  959.   (* protect a function call against signals *)
  960.     fun protect f x = let
  961.       val _ = Signals.maskSignals true
  962.       val y = (f x) handle ex => (Signals.maskSignals false; raise ex)
  963.       in
  964.         Signals.maskSignals false; y
  965.       end
  966.   (* system function to wait for input (we assume output is non-blocking) *)
  967.     val in_wait : fd -> unit = wrap_sysfn "in_wait" (c_function "wait_for_in")
  968.   in
  969.  
  970.   datatype instream = INSTRM of {
  971.       filid : int,    (* the file descriptor, ~1 for strings *)
  972.       name : string,    (* the file name *)
  973.       closed : bool ref,  (* true, if closed *)
  974.       tty : bool ref,    (* true, if this is a tty *)
  975.       buf : bytearray,    (* the buffer *)
  976.       pos : int ref,    (* the next character in the buffer to read *)
  977.       len : int ref,      (* the amount of data in the buffer *)
  978.       at_eof: bool ref    (* whether the previous read returned 0 chars *)
  979.     }
  980.   datatype outstream = OUTSTRM of {
  981.       filid : int,    (* the file descriptor *)
  982.       name : string,    (* the file name *)
  983.       closed : bool ref,  (* true, if closed *)
  984.       tty : bool ref,    (* true, if this is a tty *)
  985.       buf : bytearray,    (* the buffer *)
  986.       pos : int ref    (* the next character in the buffer to read *)
  987.     }
  988.  
  989. (* the standard streams *)
  990.   val std_in = INSTRM {
  991.       filid = 0, name = "<std_in>", closed = ref false, tty = ref(isatty 0),
  992.       buf = Assembly.A.create_b bufsize, pos = ref 0, len = ref 0,
  993.       at_eof=ref false
  994.     }
  995.   val std_out = OUTSTRM {
  996.       filid = 1, name = "<std_out>", closed = ref false, tty = ref(isatty 1),
  997.       buf = Assembly.A.create_b bufsize, pos = ref 0
  998.     }
  999.   val std_err = OUTSTRM {
  1000.       filid = 2, name = "<std_err>", closed = ref false, tty = ref(isatty 2),
  1001.       buf = Assembly.A.create_b bufsize, pos = ref 0
  1002.     }
  1003.  
  1004. (* the lists of open streams *)
  1005.   val instreams = ref [std_in]
  1006.   val outstreams = ref[std_out, std_err]
  1007.  
  1008. (* add a stream to the stream lists *)
  1009.   val add_in = protect(fn s => (instreams := s :: !instreams))
  1010.   val add_out = protect(fn s => (outstreams := s :: !outstreams))
  1011.  
  1012. (* remove a stream from the stream list *)
  1013.   fun remove_in (INSTRM{pos, ...}) = let
  1014.     fun remove [] = []
  1015.       | remove ((s as INSTRM{pos=p, ...})::r) =
  1016.           if ieql(cast pos, cast p) then r else s :: (remove r)
  1017.     in
  1018.       instreams := remove(!instreams)
  1019.     end
  1020.   val remove_in = protect remove_in
  1021.   fun remove_out (OUTSTRM{filid, ...}) = let
  1022.     fun remove [] = []
  1023.       | remove ((s as OUTSTRM{filid=f, ...})::r) =
  1024.           if ieql(filid, f) then r else s :: (remove r)
  1025.     in
  1026.       outstreams := remove(!outstreams)
  1027.     end
  1028.   val remove_out = protect remove_out
  1029.  
  1030. (* open an input stream *)
  1031.   fun open_in s = let
  1032.     val f = openf(s, O_READ)
  1033.           handle (SystemCall message) =>
  1034.             raise Io("open_in \"" ^ s ^ "\": " ^ message)
  1035.     val s = INSTRM {
  1036.         filid = f, name = s, closed = ref false, tty = ref(isatty f),
  1037.         buf = Assembly.A.create_b bufsize, pos = ref 0, len = ref 0,
  1038.         at_eof = ref false
  1039.           }
  1040.     in
  1041.       add_in s; s
  1042.     end
  1043. (* open a string as an input stream *)
  1044.   fun open_string s = let
  1045.     val (buffer, n) = if (boxed s)
  1046.           then (cast s, slength s)
  1047.           else let val a = Assembly.A.create_b 1
  1048.         in bstore(a, 0, cast s); (a, 1) end
  1049.     in
  1050.       INSTRM {
  1051.           filid = ~1, name = "<string>", closed = ref false, tty = ref false,
  1052.           buf = buffer, pos = ref 0, len = ref n, at_eof=ref false
  1053.         }
  1054.     end
  1055.  
  1056. (* open an outstream in the given mode *)
  1057.   local
  1058.     fun open_o (mode, cmd) s = let
  1059.       val f = openf(s, mode)
  1060.       val s = OUTSTRM {
  1061.           filid = f, name = s, closed = ref false, tty = ref(isatty f),
  1062.           buf = Assembly.A.create_b bufsize, pos = ref 0
  1063.         }
  1064.       in
  1065.         add_out s; s
  1066.       end
  1067.         handle (SystemCall msg) => error(cmd, s, msg)
  1068.   in
  1069.   val open_out = open_o (O_WRITE, "open_out")
  1070.   val open_append = open_o (O_APPEND, "open_append")
  1071.   end (* local *)
  1072.  
  1073. (* fill an input stream buffer *)
  1074.   fun filbuf (INSTRM{closed = ref true, len, pos, at_eof,...}) = 
  1075.              (len := 0; pos := 0; at_eof:= true)
  1076.     | filbuf (INSTRM{filid = ~1, pos, len, at_eof,...}) = 
  1077.              (len := 0; pos := 0; at_eof:=true)
  1078.     | filbuf (INSTRM{filid, pos, buf, len, at_eof, ...}) = (
  1079.     in_wait filid;
  1080.     protect (fn _ => (pos := 0; len := read(filid, cast buf, bufsize);
  1081.               at_eof := ieql(!len,0))) ())
  1082.  
  1083. (* flush an output stream buffer *)
  1084.   fun flushbuf (OUTSTRM{closed = ref true, name, ...}) = ()
  1085.     | flushbuf (OUTSTRM{pos = ref 0,...}) = ()
  1086.     | flushbuf (OUTSTRM{filid, pos, buf, ...}) =
  1087.     protect (fn _ => (write(filid, buf, !pos); pos := 0)) ()
  1088.  
  1089. (* flush an output stream (user's version) *)
  1090.   fun flush_out (f as OUTSTRM{name, ...}) = (flushbuf f)
  1091.     handle (SystemCall msg) => error("flush_out", name, msg)
  1092.  
  1093.   fun flush_output_ttys((f as OUTSTRM{tty,...})::rest) =
  1094.            (if !tty then flush_out f else (); flush_output_ttys rest)
  1095.     | flush_output_ttys nil = ()
  1096.  
  1097.   local
  1098.     fun close_file (fd, cmd, name) = (close fd)
  1099.       handle (SystemCall msg) => error(cmd, name, msg)
  1100.   in
  1101. (* close an instream *)
  1102.   fun close_in (INSTRM{closed = ref true, name,...}) = ()
  1103.     | close_in (INSTRM{filid = ~1, closed, len, pos,...}) = (
  1104.     closed := true; len := 0; pos := 1)
  1105.     | close_in (f as INSTRM{filid, pos, len, closed, name,...}) = (
  1106.     closed := true; len := 0; pos := 1; remove_in f;
  1107.     close_file (filid, "close_in", name))
  1108. (* close and flush an outstream *)
  1109.   fun close_out (OUTSTRM{closed = ref true,name,...}) = ()
  1110.     | close_out (f as OUTSTRM{filid,pos,closed,name,...}) = (
  1111.     flushbuf f; pos := 0; closed := true; remove_out f;
  1112.     close_file (filid, "close_out", name))
  1113.   end (* local *)
  1114.  
  1115. (* return the next character in an instream *)
  1116.   fun look (INSTRM{closed = ref true,...}) = ""
  1117.     | look (INSTRM{at_eof = ref true,...}) = ""
  1118.     | look (f as INSTRM{len, pos, buf,...}) = if (!len > !pos)
  1119.     then charOf(buf, !pos)
  1120.     else (filbuf f; if ieql(!len, 0) then "" else look f)
  1121. (* return the next character in an instream (user's version) *)
  1122.   fun lookahead (f as INSTRM{name, ...}) = (look f)
  1123.     handle (SystemCall msg) => error("lookahead", name, msg)
  1124.  
  1125. (* test an instream for EOF *)
  1126.   fun end_of_stream (INSTRM{closed = ref true, ...}) = true
  1127.     | end_of_stream (f as INSTRM{name, ...}) = (
  1128.     case (look f) of "" => true | _ => false)
  1129.       handle (SystemCall msg) => error("end_of_stream", name, msg)
  1130.  
  1131. (* read a large amount of data *)
  1132.   fun biginput (filid, k) = let
  1133.     val a = Assembly.A.create_s k
  1134.     val len = read(filid, cast a, k)
  1135.     in
  1136.       if (ieql(len, k)) then a else PreString.substring(a, 0, len)
  1137.     end
  1138.  
  1139. (* input characters from an input stream (curried version) *)
  1140.   fun inputc (f as INSTRM{filid, pos, len, buf, closed, name, at_eof,...}) i = let
  1141.     val remaining = (!len - !pos)
  1142.     in
  1143.       if (remaining >= i)
  1144.         then if ieql(i, 1)
  1145.           then let
  1146.         val p = !pos
  1147.         in
  1148.           pos := p+1; charOf(buf, p)
  1149.         end
  1150.         else if (i < 0)
  1151.           then error("input", name, "negative character count")
  1152.         else let
  1153.           val s = ByteArray.extract(buf, !pos, i)
  1154.           in
  1155.         pos := !pos + i; s
  1156.           end
  1157.       else if (remaining > 0)
  1158.         then let
  1159.           val s = ByteArray.extract(buf, !pos, remaining)
  1160.           in
  1161.         pos := !len; s
  1162.           end
  1163.       else if (!closed) orelse (filid < 0)
  1164.         then ""
  1165.       else let
  1166.         val _ = if ieql(filid,0) then flush_output_ttys (!outstreams)
  1167.                      else ()
  1168.         val avail = if (i <= bufsize) then i
  1169.               else let val c = fionread filid
  1170.                 in if (i < c) then i else c end
  1171.         in
  1172.           if avail > bufsize
  1173.         then (at_eof:=false; biginput (filid, avail))
  1174.         else (filbuf f; if ieql(!len, 0) 
  1175.               then ""
  1176.               else inputc f i)
  1177.         end
  1178.           handle (SystemCall s) => error("input", name, s)
  1179.     end
  1180.  
  1181. (* read some characters from an input stream *)
  1182.   fun input (f, i) = let
  1183.     val s = inputc f i
  1184.     val len = if boxed s then InLine.slength s else 1
  1185.     in
  1186.       if ieql(len, 0) then ""
  1187.       else if ieql(len,i) then s
  1188.           else let fun g(done,remain) =
  1189.                    if ieql(remain,0) then PreString.implode(List.rev done)
  1190.                    else let val s = inputc f remain
  1191.                             val len = if boxed s then InLine.slength s else 1
  1192.                          in if ieql(len,0) then g(done,0)
  1193.                             else g(s::done, remain-len)
  1194.                         end
  1195.                 in g([s], i-len)
  1196.                end
  1197.       end
  1198.  
  1199. (* read a line from an instream *)
  1200.   fun input_line (INSTRM{closed = ref true, ...}) = ""
  1201.     | input_line (f as INSTRM{pos, len, buf, name, filid, ...}) = let
  1202.     val l = !len
  1203.     fun next j = if ieql(j, l)
  1204.           then let
  1205.         val s = ByteArray.extract(buf, !pos, l - !pos)
  1206.         in 
  1207.           if ieql(filid,0) then flush_output_ttys (!outstreams)
  1208.                    else ();
  1209.           filbuf f;
  1210.           if ieql(!len, 0) then s else s ^ input_line f
  1211.         end
  1212.           else if (ieql(byteof(buf, j), 10 (* "\n" *)))
  1213.         then inputc f ((j + 1) - !pos)
  1214.         else next(j+1)
  1215.      in
  1216.         next (!pos)
  1217.      end
  1218.        handle (SystemCall s) => error("input_line", name, s)
  1219.  
  1220. (* write a string to an outstream (curried version) *)
  1221.   fun outputc (f as OUTSTRM{filid, buf, pos, tty, closed, name,...}) s = (
  1222.     if !closed
  1223.       then error("output", name, "closed outstream")
  1224.     else if (boxed s)
  1225.       then let val l = slength s
  1226.       in
  1227.         if (l > 4 * bufsize)
  1228.           then (flushbuf f; write(filid, cast s, l))
  1229.           else let
  1230.         val istty = !tty
  1231.         fun loop (i, j) = if (i < l)
  1232.               then let val c = ordof(s, i) and k = j+1
  1233.             in
  1234.               bstore (buf, j, c);
  1235.               if ieql(k, bufsize) orelse (istty andalso ieql(c, 10))
  1236.                 then (pos := k; flushbuf f; loop(i+1, 0))
  1237.                 else (loop(i+1, k))
  1238.             end
  1239.               else (pos := j)
  1240.         in
  1241.           loop (0, !pos)
  1242.         end
  1243.       end
  1244.     else (
  1245.       bstore(buf,!pos,cast s);
  1246.       pos := !pos + 1;
  1247.       if ieql(!pos, bufsize) orelse (!tty andalso ieql(cast s, 10))
  1248.         then (flushbuf f)
  1249.         else ())
  1250.     ) handle (SystemCall s) => error("output", name, s)
  1251. (* write a string to an outstream *)
  1252.   fun output(f,s) = outputc f s
  1253.  
  1254. (* return the number of available characters in an instream *)
  1255.   fun can_input (INSTRM{closed = ref true, ...}) = 0
  1256.     | can_input (INSTRM{filid = ~1, pos, len, ...}) = (!len - !pos)
  1257.     | can_input (INSTRM{filid, pos, len, name, ...}) = let
  1258.     val n = (!len - !pos) + fionread filid
  1259.     in
  1260.       if (n < 0)
  1261.         then error("can_input", name, "negative character count")
  1262.         else n
  1263.     end
  1264.       handle SysError (_, s) => error("can_input", name, s)    
  1265.  
  1266. (* execute the specified command (with our environment) *)
  1267.   fun execute_in_env (cmd, args, env) = let
  1268.     fun basename s = let
  1269.           val len = slength s
  1270.           fun f i = if ieql(i, len)
  1271.               then s
  1272.             else if ieql(ordof(s, i), 47 (* ordof "/" *))
  1273.               then g (i+1, i+1)
  1274.               else f (i+1)
  1275.           and g (base, i) = if ieql(i, len)
  1276.               then PreString.substring(s, base, len-base)
  1277.             else if ieql(ordof(s, i), 47 (* ordof "/" *))
  1278.               then g (i+1, i+1)
  1279.               else g (base, i+1)
  1280.           in
  1281.         f 0
  1282.           end
  1283.     fun mapCString [] = []
  1284.       | mapCString (s::r) = (c_string s)::(mapCString r)
  1285.     val cArgs = mapCString ((basename cmd) :: args)
  1286.     val cEnv = mapCString env
  1287.     val (fdin, fdout) = exec (c_string cmd, cArgs, cEnv)
  1288.           handle (SysError(_,msg)) => error("execute", cmd, msg)
  1289.     val r = INSTRM {
  1290.         filid = fdin, name = "<pipe_in>", closed = ref false,
  1291.         tty = ref false, buf = Assembly.A.create_b bufsize,
  1292.         pos = ref 0, len = ref 0, at_eof=ref false
  1293.           }
  1294.     val w = OUTSTRM {
  1295.         filid = fdout, name="<pipe_out>", closed = ref false,
  1296.         tty = ref false, buf = Assembly.A.create_b bufsize,
  1297.         pos = ref 0
  1298.           }
  1299.     in
  1300.       add_in r; add_out w;
  1301.       (r, w)
  1302.     end
  1303.   fun execute (cmd, args) = execute_in_env (cmd, args, environ())
  1304.  
  1305.   fun is_term_in (INSTRM{tty=ref x,...}) = x
  1306.   fun is_term_out (OUTSTRM{tty=ref x,...}) = x
  1307.  
  1308.   fun set_term_in (INSTRM{tty, ...}, t) = (tty := t)
  1309.   fun set_term_out (OUTSTRM{tty, ...}, t) = (tty := t)
  1310.  
  1311. (* export the current world to the given file *)
  1312.   fun exportML filename = let
  1313.     val filid = openf (filename, O_WRITE)
  1314.     in
  1315.       cleanup CleanForExportML;
  1316.       if (export filid)
  1317.         then (
  1318.           cleanup CleanForInit;
  1319.           PreStats.reset();  (* reset timing statistics *)
  1320.           true)
  1321.       else (close filid; false)
  1322.       end handle SysError(_,s) => error("exportML",filename,s)
  1323.            | SystemCall s => error ("exportML",filename,s)
  1324.  
  1325.   val debugInterface = Hooks.debugInterface
  1326.  
  1327.  
  1328. (* export a function to a file *)
  1329. (* It's necessary to fool around with "restart" so that
  1330.    the exception handler of exportFn's caller will be abandoned. *)
  1331.   val restart = callcc (fn k => 
  1332.     let val (filename,func) = callcc(fn j => throw k j);
  1333.     val filid = openf (filename, O_WRITE)
  1334.           handle (SystemCall s) => error("exportFn", filename, s)
  1335.     val pr = outputc std_out
  1336.     exception OutOfHere
  1337.      in
  1338.       cleanup CleanForExportFn;
  1339.       Hooks.clear();
  1340.       Signals.maskSignals true;
  1341.       if (export filid)
  1342.         then (
  1343.           callcc (fn k => (
  1344.         Hooks.toplevelcont := k;
  1345.         Signals.maskSignals false;
  1346.         cleanup CleanForInit;
  1347.         (func (argv(), environ()))
  1348.           handle exn => (
  1349.             pr "uncaught exception "; pr (PreLim.exn_name exn); pr "\n");
  1350.         shutdown()));
  1351.           (* we can only get here via a throw to the top-level cont *)
  1352.           pr "\nInterrupt\n";
  1353.           shutdown())
  1354.         else shutdown()
  1355.     end)
  1356.                
  1357.   val exportFn = throw restart
  1358.  
  1359. (* blast objects *)
  1360.   fun blast_write (s as OUTSTRM{filid, name, ...}, obj) = (
  1361.     flushbuf s; blas(filid, obj))
  1362.       handle (SystemCall msg) => error("blast_write", name, msg)
  1363.            | SysError(_,msg) => error("blast_write", name, msg)
  1364.   fun blast_read(f,n) = salb (input(f,n))
  1365.  
  1366. (* IO cleanup code *)
  1367.   fun cleanIO CleanForQuit = (
  1368.       (* close and flush all streams *)
  1369.     List.app (fn s => ((close_in s) handle _ => ())) (!instreams);
  1370.     List.app (fn s => ((close_out s) handle _ => ())) (!outstreams))
  1371.     | cleanIO CleanForInit = let
  1372.       (* mark all streams as closed *)
  1373.     val _ = List.app (fn INSTRM{closed, ...} => closed := true) (!instreams)
  1374.     val _ = List.app (fn OUTSTRM{closed, ...} => closed := true) (!outstreams)
  1375.       (* set up the standard streams *)
  1376.     val INSTRM{pos=pos_in,tty=tty_in,closed=closed_in,len,...} = std_in
  1377.     val OUTSTRM{pos=pos_out,tty=tty_out,closed=closed_out,...} = std_out
  1378.     val OUTSTRM{pos=pos_err,tty=tty_err,closed=closed_err,...} = std_err
  1379.     in
  1380.       pos_in := 0; tty_in := isatty 0; closed_in := false; len := 0;
  1381.       pos_out := 0; tty_out := isatty 1; closed_out := false;
  1382.       pos_err := 0; tty_err := isatty 1; closed_err := false;
  1383.       PreLim.interactive := !tty_in;
  1384.       instreams := [std_in];
  1385.       outstreams := [std_out, std_err]
  1386.     end
  1387.     | cleanIO _ =  List.app flushbuf (!outstreams)  (* for export *)
  1388.   val _ = (addCleaner("IO", cleanIO))
  1389.  
  1390.  end (* local open ... *)
  1391. end (* structure PreIO *)
  1392.  
  1393. abstraction IO : IO = PreIO
  1394.  
  1395. structure Bool : BOOL =
  1396. struct
  1397.   open PrimTypes (* for datatypes bool and option *)
  1398.  
  1399.   fun not true = false
  1400.     | not false = true
  1401.   fun makestring true = "true"
  1402.     | makestring false = "false"
  1403.   local val pr = IO.outputc IO.std_out in
  1404.   fun print b = pr(makestring b)
  1405.   end
  1406. end (* structure Bool *)
  1407.  
  1408. structure String (*: STRING*) =
  1409. struct
  1410.   local open PrimTypes InLine
  1411.   in 
  1412.   infix 4 > < >= <=
  1413.   infix 6 ^
  1414.   type string = string
  1415.   fun length s = if boxed s then slength s else 1
  1416.   val size = length
  1417.   exception Substring = PreString.Substring
  1418.   val substring = PreString.substring
  1419.   fun explode s =
  1420.     if boxed s
  1421.       then let fun f(l,~1) = l
  1422.              | f(l, i) = f(cast(ordof(s,i)) :: l, i-1)
  1423.         in f(nil, slength s - 1)
  1424.            end
  1425.       else [s]
  1426.   val op ^ = PreString.^
  1427.   exception Chr
  1428.   val chr : int -> string = 
  1429.       fn i => if lessu(i, 256) then (cast i) else raise Chr
  1430.   exception Ord = Core.Ord
  1431.   fun ord "" = raise Ord
  1432.     | ord s = if boxed s then ordof(s,0) else cast s
  1433.   val ordof = InLine.inlordof
  1434. (*    val ordof = fn (s,i) =>
  1435.     if boxed s
  1436.       then if lessu(i, slength s) then ordof(s, i) else raise Ord
  1437.       else if ieql(i,0) then cast s else raise Ord
  1438. *)
  1439.   val print = IO.outputc IO.std_out
  1440.   val implode = PreString.implode
  1441.   local fun sgtr("","") = false
  1442.     | sgtr(_,"") = true
  1443.     | sgtr("",_) = false
  1444.     | sgtr(a,b) =
  1445.       if boxed a
  1446.       then if boxed b
  1447.        then let val al = slength a and bl = slength b
  1448.             val n = if al<bl then al else bl
  1449.             fun f i = 
  1450.             if ieql(i,n) then al > bl
  1451.             else if ieql(InLine.ordof(a,i),InLine.ordof(b,i)) then f(i+1)
  1452.             else InLine.ordof(a,i) > InLine.ordof(b,i)
  1453.          in  f 0
  1454.         end
  1455.        else InLine.ordof(a,0) >= cast(b)
  1456.       else if boxed b
  1457.        then cast(a) > InLine.ordof(b,0)
  1458.        else cast(a) > cast(b)  
  1459.   in fun op <= (a,b) = Bool.not(sgtr(a,b))
  1460.      fun op < (a,b) = sgtr(b,a)
  1461.      fun op >= (a,b) = Bool.not(sgtr(b,a))
  1462.      val op > = sgtr
  1463.   end (*local fun sgtr*)
  1464.  end (*local open*)
  1465. end  (* structure String *)
  1466.  
  1467.  
  1468. structure System : SYSTEM =
  1469. struct
  1470.   structure ByteArray : BYTEARRAY = ByteArray
  1471.   structure Hooks : HOOKS = Hooks
  1472.  
  1473.   structure Symbol : SYMBOL =
  1474.   struct
  1475.    local open InLine PrimTypes Ref in
  1476.     type symbol = symbol
  1477.     datatype namespace =
  1478.        VALspace | TYCspace | SIGspace | STRspace | FCTspace | FIXspace |
  1479.        LABspace | TYVspace | FSIGspace
  1480.  
  1481.     val valSymbol = cast(fn x => !Hooks.valSymbol_ref x)
  1482.     val tycSymbol = cast(fn x => !Hooks.tycSymbol_ref x)
  1483.     val sigSymbol = cast(fn x => !Hooks.sigSymbol_ref x)
  1484.     val strSymbol = cast(fn x => !Hooks.strSymbol_ref x)
  1485.     val fctSymbol = cast(fn x => !Hooks.fctSymbol_ref x)
  1486.     val fixSymbol = cast(fn x => !Hooks.fixSymbol_ref x)
  1487.     val labSymbol = cast(fn x => !Hooks.labSymbol_ref x)
  1488.     val tyvSymbol = cast(fn x => !Hooks.tyvSymbol_ref x)
  1489.     val fsigSymbol = cast(fn x => !Hooks.fsigSymbol_ref x)
  1490.     val name      = cast(fn x => !Hooks.name_ref x)
  1491.     val makestring = cast(fn x => !Hooks.makestring_ref x)
  1492.     val kind      = cast(fn x => !Hooks.kind_ref x)
  1493.     val nameSpace = cast(fn x => !Hooks.nameSpace_ref x)
  1494.     fun makeSymbol(space,s) =
  1495.     case space
  1496.       of VALspace => valSymbol s
  1497.        | TYCspace => tycSymbol s
  1498.        | SIGspace => sigSymbol s
  1499.        | STRspace => strSymbol s
  1500.        | FCTspace => fctSymbol s
  1501.        | FIXspace => fixSymbol s
  1502.        | LABspace => labSymbol s
  1503.        | TYVspace => tyvSymbol s
  1504.        | FSIGspace => fsigSymbol s
  1505.    end (* local *)
  1506.   end (* structure Symbol *)
  1507.  
  1508.   structure Env : ENVIRONMENT =
  1509.   struct
  1510.    local open InLine PrimTypes Ref in
  1511.     structure Symbol = Symbol
  1512.     exception Unbound = Assembly.UnboundTable
  1513.     type environment = environment
  1514.     type staticEnv = staticEnv
  1515.  
  1516.     val emptyEnv = cast(fn x => !Hooks.emptyEnv_ref x)
  1517.     val staticPart = cast(fn x => !Hooks.staticPart_ref x)
  1518.     val concatEnv = cast(fn x => !Hooks.concatEnv_ref x)
  1519.     val layerEnv = cast(fn x => !Hooks.layerEnv_ref x)
  1520.     val layerStatic = cast(fn x => !Hooks.layerStatic_ref x)
  1521.     val filterEnv = cast(fn x => !Hooks.filterEnv_ref x)
  1522.     val filterStaticEnv = cast(fn x => !Hooks.filterStaticEnv_ref x)
  1523.     val catalogEnv = cast(fn x => !Hooks.catalogEnv_ref x)
  1524.     val describe = cast(fn x => !Hooks.describe_ref x)
  1525.     val pervasiveEnvRef : environment ref = cast(Hooks.pervasiveEnvRef)
  1526.     val topLevelEnvRef : environment ref = cast(Hooks.topLevelEnvRef)
  1527.  
  1528.    end (* local *)
  1529.   end (* structure Env *)
  1530.  
  1531.  
  1532.   structure Ast = struct
  1533.  
  1534.   local
  1535.     open Symbol InLine
  1536.   in
  1537.   type symbol = symbol
  1538.   abstype fixity = NONfix | INfix of (int*int)
  1539.   with
  1540.     fun infixleft n = INfix (n+n, n+n+1)
  1541.     fun infixright n = INfix (n+n+1, n+n)
  1542.   end
  1543.  
  1544.   (* to mark positions in files *)
  1545.   type filePos = int
  1546.   (* symbolic path (Modules.spath) *)
  1547.   type path = symbol list
  1548.  
  1549.   (* EXPRESSIONS *)
  1550.  
  1551.   datatype exp
  1552.     = VarExp of path        (* variable *)
  1553.     | FnExp of rule list        (* abstraction *)
  1554.     | AppExp of {function:exp,argument:exp}
  1555.                   (* application *)
  1556.     | CaseExp of{expr:exp,rules:rule list}
  1557.                   (* case expression *)
  1558.     | LetExp of {dec:dec,expr:exp} (* let expression *)
  1559.     | SeqExp of exp list        (* sequence of expressions *)
  1560.     | IntExp of int        (* integer *)
  1561.     | RealExp of string        (* floating point coded by its string *)
  1562.     | StringExp of string        (* string *)
  1563.     | RecordExp of (symbol * exp) list    (* record *)
  1564.     | TupleExp of exp list    (* tuple (derived form) *)
  1565.     | SelectorExp of symbol    (* selector of a record field *)
  1566.     | ConstraintExp of {expr:exp,constraint:ty}
  1567.                   (* type constraint *)
  1568.     | HandleExp of {expr:exp, rules:rule list}
  1569.                   (* exception handler *)
  1570.     | RaiseExp of exp        (* raise an exception *)
  1571.     | IfExp of {test:exp, thenCase:exp, elseCase:exp}
  1572.                   (* if expression (derived form) *)
  1573.     | AndalsoExp of exp * exp    (* andalso (derived form) *)
  1574.     | OrelseExp of exp * exp    (* orelse (derived form) *)
  1575.     | WhileExp of {test:exp,expr:exp}
  1576.                   (* while (derived form) *)
  1577.     | MarkExp of exp * filePos * filePos    (* mark an expression *)
  1578.     | VectorExp of exp list        (* vector *)
  1579.  
  1580.  
  1581.   (* RULE for case functions and exception handler *)
  1582.   and rule = Rule of {pat:pat,exp:exp}
  1583.  
  1584.   (* PATTERN *)
  1585.   and pat = WildPat                (* empty pattern *)
  1586.       | VarPat of path            (* variable pattern *)
  1587.       | IntPat of int                (* integer *)
  1588.       | RealPat of string            (* floating point number *)
  1589.       | StringPat of string            (* string *)
  1590.       | RecordPat of {def:(symbol * pat) list, flexibility:bool}
  1591.                           (* record *)
  1592.       | TuplePat of pat list            (* tuple *)
  1593.       | AppPat of {constr:path,argument:pat}    (* application *)
  1594.       | ConstraintPat of {pattern:pat,constraint:ty}
  1595.                           (* constraint *)
  1596.       | LayeredPat of {varPat:pat,expPat:pat}    (* as expressions *)
  1597.       | MarkPat of pat * filePos * filePos    (* mark a pattern *)
  1598.           | VectorPat of pat list               (* vector pattern *)
  1599.  
  1600.  
  1601.   (* STRUCTURE EXPRESSION *)
  1602.   and strexp = VarStr of path            (* variable structure *)
  1603.          | StructStr of dec            (* defined structure *)
  1604.          | AppStr of path * (strexp * bool) list (* application *)
  1605.          | LetStr of dec * strexp        (* let in structure *)
  1606.          | MarkStr of strexp * filePos * filePos (* mark *)
  1607.  
  1608.   (* FUNCTOR EXPRESSION *)
  1609.   and fctexp = VarFct of path * fsigexp option    (* functor variable *)
  1610.          | FctFct of {            (* definition of a functor *)
  1611.           params       : (symbol option * sigexp) list,
  1612.           body       : strexp,
  1613.           constraint : sigexp option}
  1614.          | LetFct of dec * fctexp
  1615.          | AppFct of path * (strexp * bool) list * fsigexp option
  1616.                           (* application *)
  1617.          | MarkFct of fctexp * filePos * filePos (* mark *)
  1618.  
  1619.   (* SIGNATURE EXPRESSION *)
  1620.   and sigexp = VarSig of symbol            (* signature variable *)
  1621.          | SigSig of spec list        (* defined signature *)
  1622.          | MarkSig of sigexp * filePos * filePos    (* mark *)
  1623.  
  1624.   (* FUNCTOR SIGNATURE EXPRESSION *)
  1625.   and fsigexp = VarFsig of symbol        (* funsig variable *)
  1626.           | FsigFsig of {param: (symbol option * sigexp) list, def:sigexp}
  1627.                           (* defined funsig *)
  1628.           | MarkFsig of fsigexp * filePos * filePos    (* mark a funsig *)
  1629.  
  1630.   (* SPECIFICATION FOR SIGNATURE DEFINITIONS *)
  1631.   and spec = StrSpec of (symbol * sigexp) list            (* structure *)
  1632.        | TycSpec of ((symbol * tyvar list) list * bool)    (* type *)
  1633.        | FctSpec of (symbol * fsigexp) list            (* functor *)
  1634.        | ValSpec of (symbol * ty) list            (* value *)
  1635.        | DataSpec of db list                (* datatype *)
  1636.        | ExceSpec of (symbol * ty option) list        (* exception *)
  1637.        | FixSpec of  {fixity: fixity, ops: symbol list}     (* fixity *)
  1638.        | ShareSpec of path list            (* structure sharing *)
  1639.        | ShatycSpec of path list            (* type sharing *)
  1640.        | LocalSpec of spec list * spec list        (* local specif *)
  1641.        | IncludeSpec of symbol            (* include specif *)
  1642.        | OpenSpec of path list            (* open structures *)
  1643.        | MarkSpec of spec * filePos * filePos        (* mark a spec *)
  1644.  
  1645.   (* DECLARATIONS (let and structure) *)
  1646.   and dec    = ValDec of vb list            (* values *)
  1647.       | ValrecDec of rvb list            (* recursive values *)
  1648.       | FunDec of fb list                (* recurs functions *)
  1649.       | TypeDec of tb list                (* type dec *)
  1650.       | DatatypeDec of {datatycs: db list, withtycs: tb list}
  1651.                               (* datatype dec *)
  1652.       | AbstypeDec of {abstycs: db list, withtycs: tb list, body: dec}
  1653.                               (* abstract type *)
  1654.       | ExceptionDec of eb list            (* exception *)
  1655.       | StrDec of strb list                (* structure *)
  1656.       | AbsDec of strb list                (* abstract struct *)
  1657.       | FctDec of fctb list                (* functor *)
  1658.       | SigDec of sigb list                (* signature *)
  1659.       | FsigDec of fsigb list                (* funsig *)
  1660.       | LocalDec of dec * dec                (* local dec *)
  1661.       | SeqDec of dec list                (* sequence of dec *)
  1662.       | OpenDec of path list                (* open structures *)
  1663.       | OvldDec of symbol * ty * exp list    (* overloading (internal) *)
  1664.       | FixDec of {fixity: fixity, ops: symbol list}  (* fixity *)
  1665.       | ImportDec of string list        (* import (unused) *)
  1666.       | MarkDec of dec * filePos * filePos        (* mark a dec *)
  1667.  
  1668.   (* VALUE BINDINGS *)
  1669.   and vb = Vb of {pat:pat, exp:exp}
  1670.      | MarkVb of vb * filePos * filePos
  1671.  
  1672.   (* RECURSIVE VALUE BINDINGS *)
  1673.   and rvb = Rvb of {var:symbol, exp:exp, resultty: ty option}
  1674.       | MarkRvb of rvb * filePos * filePos
  1675.  
  1676.   (* RECURSIVE FUNCTIONS BINDINGS *)
  1677.   and fb = Fb of {var:symbol, clauses:clause list}
  1678.      | MarkFb of fb * filePos * filePos
  1679.  
  1680.   (* CLAUSE: a definition for a single pattern in a function binding *)
  1681.   and clause = Clause of {pats: pat list, resultty: ty option, exp:exp}
  1682.  
  1683.   (* TYPE BINDING *)
  1684.   and tb = Tb of {tyc : symbol, def : ty, tyvars : tyvar list}
  1685.      | MarkTb of tb * filePos * filePos
  1686.  
  1687.   (* DATATYPE BINDING *)
  1688.   and db = Db of {tyc : symbol, tyvars : tyvar list,
  1689.           def : (symbol * ty option) list}
  1690.      | MarkDb of db * filePos * filePos
  1691.  
  1692.   (* EXCEPTION BINDING *)
  1693.   and eb = EbGen of {exn: symbol, etype: ty option} (* Exception definition *)
  1694.      | EbDef of {exn: symbol, edef: path}      (* defined by equality *)
  1695.      | MarkEb of eb * filePos * filePos
  1696.  
  1697.   (* STRUCTURE BINDING *)
  1698.   and strb = Strb of {name: symbol,def: strexp,constraint: sigexp option}
  1699.        | MarkStrb of strb * filePos * filePos
  1700.  
  1701.   (* FUNCTOR BINDING *)
  1702.   and fctb = Fctb of {name: symbol,def: fctexp}
  1703.        | MarkFctb of fctb * filePos * filePos
  1704.  
  1705.   (* SIGNATURE BINDING *)
  1706.   and sigb = Sigb of {name: symbol,def: sigexp}
  1707.        | MarkSigb of sigb * filePos * filePos
  1708.  
  1709.   (* FUNSIG BINDING *)
  1710.   and fsigb = Fsigb of {name: symbol,def: fsigexp}
  1711.         | MarkFsigb of fsigb * filePos * filePos
  1712.  
  1713.   (* TYPE VARIABLE *)
  1714.   and tyvar = Tyv of symbol
  1715.         | MarkTyv of tyvar * filePos * filePos
  1716.  
  1717.   (* TYPES *)
  1718.   and ty 
  1719.       = VarTy of tyvar            (* type variable *)
  1720.       | ConTy of symbol list * ty list    (* type constructor *)
  1721.       | RecordTy of (symbol * ty) list     (* record *)
  1722.       | TupleTy of ty list        (* tuple *)
  1723.       | MarkTy of ty * filePos * filePos    (* mark type *)
  1724.  
  1725.   end
  1726.  
  1727.   end (* structure Ast *)
  1728.  
  1729.   structure Code : CODE =
  1730.     struct
  1731.       structure IO = IO
  1732.       type object = Assembly.object
  1733.       abstraction AbsCode : sig
  1734.       type code_string
  1735.       val mkCode : string -> (code_string * (unit -> unit))
  1736.       val sizeOf : code_string -> int
  1737.     end = struct
  1738.       type code_string = string
  1739.       val mkCode = CInterface.c_function "mkcode"
  1740.       val sizeOf = String.size
  1741.     end
  1742.       datatype code = CODE of (AbsCode.code_string * (unit -> unit))
  1743.       fun mkCode s = CODE(AbsCode.mkCode s)
  1744.       fun sizeOf (CODE(cs, _)) = AbsCode.sizeOf cs
  1745.       fun inputCode (instrm, nbytes) = mkCode(IO.input(instrm, nbytes))
  1746.       fun apply (CODE(_, exc)) = (InLine.cast exc) : 'a -> 'b
  1747.     end (* Code *)
  1748.  
  1749.   structure PrettyPrint : PRETTYPRINT =
  1750.   struct
  1751.    local open InLine PrimTypes Ref in
  1752.     abstype ppstream = X with end
  1753.     type ppconsumer = {linewidth : int, 
  1754.                consumer  : string -> unit,
  1755.                flush     : unit -> unit}
  1756.     datatype break_style = CONSISTENT | INCONSISTENT
  1757.     exception PP_FAIL of string
  1758.  
  1759.     val mk_ppstream = cast(fn x => !Hooks.mk_ppstream_ref x)
  1760.     val dest_ppstream = cast(fn x => !Hooks.dest_ppstream_ref x)
  1761.     val begin_block = cast(fn x => !Hooks.begin_block_ref x)
  1762.     val end_block = cast(fn x => !Hooks.end_block_ref x)
  1763.     val add_break = cast(fn x => !Hooks.add_break_ref x)
  1764.     val add_string = cast(fn x => !Hooks.add_string_ref x)
  1765.     val add_newline = cast(fn x => !Hooks.add_newline_ref x)
  1766.     val clear_ppstream = cast(fn x => !Hooks.clear_ppstream_ref x)
  1767.     val flush_ppstream = cast(fn x => !Hooks.flush_ppstream_ref x)
  1768.     val with_pp = cast(fn x => !Hooks.with_pp_ref x)
  1769.     val install_pp = cast(fn x => !Hooks.install_pp_ref x)
  1770.  
  1771.     fun pp_to_string linewidth ppfn ob = 
  1772.        let val l = ref ([]:string list)
  1773.        fun attach s = l := (s::(!l))
  1774.        in  with_pp {consumer = attach, linewidth=linewidth, flush = fn()=>()}
  1775.               (fn ppstrm =>  ppfn ppstrm ob);
  1776.        String.implode(List.rev(!l))
  1777.        end;
  1778.  
  1779.    end (* local *)
  1780.   end (* structure PrettyPrint *)
  1781.  
  1782.   structure Compile : COMPILE =
  1783.   struct
  1784.    local open InLine PrimTypes Ref in
  1785.     structure PP = PrettyPrint
  1786.     structure IO = IO
  1787.     structure Ast = Ast
  1788.     type source = source
  1789.     type lvar = int
  1790.     type codeUnit = codeUnit
  1791.     type staticUnit = {staticEnv: staticEnv, boundLvars: lvar list}
  1792.     type compUnit = staticUnit * codeUnit
  1793.  
  1794.     exception Compile of string
  1795.  
  1796.     val makeSource = cast(fn x => !Hooks.makeSource_ref x)
  1797.     val closeSource = cast(fn x => !Hooks.closeSource_ref x)
  1798.     val changeLvars = cast(fn x => !Hooks.changeLvars_ref x)
  1799.     val elaborate = cast(fn x => !Hooks.elaborate_ref x)
  1800.     val parse = cast(fn x => !Hooks.parse_ref x)
  1801.     val compile = cast(fn x => !Hooks.compile_ref x)
  1802.     val compileAst = cast(fn x => !Hooks.compileAst_ref x)
  1803.     val execute = cast(fn x => !Hooks.execute_ref x)
  1804.     val eval_stream = cast(fn x => !Hooks.eval_stream_ref x)
  1805.     val use = cast(fn x => !Hooks.use_file_ref x)
  1806.     val use_stream = cast(fn x => !Hooks.use_stream_ref x)
  1807.  
  1808.    end (* local *)
  1809.   end (* structure Compile *)
  1810.  
  1811.   structure Print : PRINTCONTROL =
  1812.   struct
  1813.     type outstream = IO.outstream
  1814.     val printDepth = ref 5
  1815.     val printLength = ref 12
  1816.     val stringDepth = ref 70
  1817.     val printLoop = ref true;
  1818.     val signatures = ref 2
  1819.     val pathnames = ref 1000
  1820.     val out = ref(IO.std_out)
  1821.     val linewidth = ref 79
  1822.     fun say s = IO.outputc (Ref.! out) s
  1823.     fun flush() = IO.flush_out (Ref.! out)
  1824.   end
  1825.  
  1826.   structure Control : CONTROL =
  1827.   struct
  1828.     structure Runtime : RUNTIMECONTROL = Assembly
  1829.  
  1830.     structure MC : MCCONTROL =
  1831.     struct
  1832.       val printArgs = ref false
  1833.       val printRet = ref false
  1834.       val bindContainsVar = ref true
  1835.       val bindExhaustive = ref true
  1836.       val matchExhaustive = ref true
  1837.       val matchRedundant = ref true
  1838.       val expandResult = ref false
  1839.     end
  1840.  
  1841.     structure CG : CGCONTROL =
  1842.     struct
  1843.       structure M68 =
  1844.     struct
  1845.       val trapv = ref true
  1846.     end
  1847.       val tailrecur = ref true
  1848.       val recordopt = ref true
  1849.       val tail = ref true
  1850.       val allocprof = ref false
  1851.       val closureprint = ref false
  1852.       val closureStrategy = ref 0
  1853.       val rounds = ref 10
  1854.       val path = ref false
  1855.       val betacontract = ref true
  1856.       val eta = ref true
  1857.       val selectopt = ref true
  1858.       val dropargs = ref true
  1859.       val deadvars = ref true
  1860.       val flattenargs = ref true
  1861.       val switchopt = ref true
  1862.       val handlerfold = ref true
  1863.       val branchfold = ref true
  1864.       val arithopt = ref true
  1865.       val betaexpand = ref true
  1866.       val unroll = ref false
  1867.       val knownfiddle = ref false
  1868.       val unroll_recur = ref true
  1869.       val newconreps = ref false
  1870.       val invariant = ref true
  1871.       val targeting = ref 0
  1872.       val lambdaprop = ref false
  1873.       val hoistup = ref false
  1874.       val hoistdown = ref false
  1875.       val maxregs = ref 1000
  1876.       val recordcopy = ref true
  1877.       val tagopt = ref true
  1878.       val machdep = ref true
  1879.       val recordpath = ref true
  1880.       val misc1 = ref false
  1881.       val misc2 = ref true
  1882.       val misc3 = ref 0
  1883.       val misc4 = ref 0
  1884.       val hoist = ref false
  1885.       val argrep = ref true
  1886.       val reduce = ref false
  1887.       val bodysize = ref 20
  1888.       val reducemore = ref 15
  1889.       val alphac = ref true
  1890.       val comment = ref false
  1891.       val knownGen = ref 0
  1892.       val knownClGen = ref 0
  1893.       val escapeGen = ref 0
  1894.       val calleeGen = ref 0
  1895.       val spillGen = ref 0
  1896.       val foldconst = ref true
  1897.       val etasplit = ref true
  1898.       val printLambda = ref false
  1899.       val printit = ref false
  1900.       val printsize = ref false
  1901.       val scheduling = ref true
  1902.       val lambdaopt = ref true
  1903.       val cpsopt = ref true
  1904.       val cse = ref false
  1905.       val optafterclosure = ref false
  1906.       val calleesaves = ref(Assembly.calleesaves)
  1907.       val extraflatten = ref true
  1908.       val uncurry = ref true
  1909.       val ifidiom = ref true
  1910.       val comparefold = ref true
  1911.       val csehoist = ref false
  1912.       val rangeopt = ref false
  1913.       val floatargs = ref 0
  1914.       val floatvars = ref 0
  1915.       val floatreg_params = ref true
  1916.       val icount = ref false
  1917.       val representations = ref false
  1918.     end
  1919.  
  1920.     structure Print : PRINTCONTROL = Print
  1921.  
  1922.     structure Debug : DEBUG =
  1923.     struct
  1924.       val debugging = ref false
  1925.       val getDebugf = InLine.cast Core.getDebugf
  1926.       val interface = InLine.cast PreIO.debugInterface
  1927.     end
  1928.  
  1929.     val allocProfReset = (fn x => (Ref.! Hooks.allocProfReset_ref) x)
  1930.     val allocProfPrint = (fn x => (Ref.! Hooks.allocProfPrint_ref) x)
  1931.  
  1932.     val prLambda = PreLim.prLambda
  1933.     val debugging = ref false
  1934.     val primaryPrompt = ref "- "
  1935.     val secondaryPrompt = ref "= "
  1936.     val internals = ref false
  1937.     val weakUnderscore = ref false
  1938.     val interp = ref false
  1939.     val debugLook = ref false
  1940.     val debugCollect = ref false
  1941.     val debugBind = ref false
  1942.     val saveLambda = ref false
  1943.     val saveLvarNames = ref false
  1944.     val timings = ref false
  1945.     val reopen = ref false
  1946.     val markabsyn = ref true
  1947.     val indexing = ref false
  1948.     val instSigs = ref true
  1949.     val quotation = ref false  (* controls backquote quotation *)
  1950.   end (* structure Control *)
  1951.  
  1952.   structure Tags : TAGS = Tags
  1953.  
  1954.   abstraction Weak : WEAK =
  1955.     struct
  1956.       type 'a weak = 'a
  1957.       fun weak (x : 'a) : 'a weak = InLine.mkspecial(Tags.special_weak, x)
  1958.       fun strong (x : 'a weak) : 'a option =
  1959.         if (InLine.ieql(InLine.getspecial x, Tags.special_weak))
  1960.           then SOME(InLine.subscript(InLine.cast x, 0))
  1961.           else NONE
  1962.       type weak' = Assembly.object
  1963.       fun weak' x = InLine.mkspecial(Tags.special_weak, x)
  1964.       fun strong' x = InLine.ieql(InLine.getspecial x, Tags.special_weak)
  1965.     end (* Weak *)
  1966.  
  1967.   abstraction Susp : SUSP =
  1968.     struct
  1969.       type 'a susp = 'a
  1970.       fun delay (f : unit -> 'a) = InLine.mkspecial(Tags.special_unevaled_susp, f)
  1971.       fun force (x : 'a susp) =
  1972.         if (InLine.ieql(InLine.getspecial x, Tags.special_unevaled_susp))
  1973.           then let
  1974.         val y : 'a = InLine.subscript (InLine.cast x, 0) ()
  1975.         in
  1976.           InLine.update (InLine.cast x, 0, y);
  1977.           InLine.setspecial(InLine.cast x, Tags.special_evaled_susp);
  1978.           y
  1979.         end
  1980.           else InLine.subscript (InLine.cast x, 0)
  1981.     end (* Susp *)
  1982.  
  1983.   abstraction CC : sig type 'a control_cont end =
  1984.     struct type 'a control_cont = 'a cont end
  1985.  
  1986.   (* fully polymorphic (and thus not typesafe) versions of the continuation
  1987.    * operations
  1988.    *)
  1989.   structure PolyCont : POLY_CONT =
  1990.   struct
  1991.     type 'a cont = 'a cont
  1992.     val callcc    = InLine.cast()
  1993.     val throw    = InLine.cast()
  1994.     type 'a control_cont = 'a CC.control_cont
  1995.     val capture    = InLine.cast()
  1996.     val escape    = InLine.cast()
  1997.   end (* PolyCont *)
  1998.  
  1999.   structure Timer =
  2000.   struct
  2001.     open Time InLine PreString
  2002.  
  2003.     datatype timer = Timer of {usr : time, sys : time, gc : time}
  2004.     fun timer () = Timer(CInterface.gettime())
  2005.  
  2006.     val start_timer = timer
  2007.     fun sub_time (TIME{sec=s2,usec=u2}, TIME{sec=s1,usec=u1}) = let
  2008.       val (s, u) = (s2-s1, u2-u1)
  2009.       val (s, u) = if (u < 0) then (s-1, u+1000000) else (s, u)
  2010.       in
  2011.         TIME{sec=s, usec=u}
  2012.       end
  2013.     fun check_timer (Timer{usr=u_start, sys=s_start, gc=g_start}) = let
  2014.       val (Timer{usr=u_cur, sys=s_cur, gc=g_cur}) = timer()
  2015.       in
  2016.         sub_time(sub_time(u_cur, u_start), sub_time(g_cur, g_start))
  2017.       end
  2018.     fun check_timer_sys (Timer{sys=s_start, ...}) = let
  2019.       val (Timer{sys=s_cur, ...}) = timer()
  2020.       in
  2021.         sub_time(s_cur, s_start)
  2022.       end
  2023.     fun check_timer_gc (Timer{gc=g_start, ...}) = let
  2024.       val (Timer{gc=g_cur, ...}) = timer()
  2025.       in
  2026.         sub_time(g_cur, g_start)
  2027.       end
  2028.     fun makestring(TIME{sec,usec}) =
  2029.       let val filler = if usec <= 0 then ""
  2030.                else if usec < 10 then "00000"
  2031.                else if usec < 100 then "0000"
  2032.                else if usec < 1000 then "000"
  2033.                else if usec < 10000 then "00"
  2034.                else if usec < 100000 then "0"
  2035.                else ""
  2036.       in  imakestring sec ^ "." ^ filler ^ imakestring usec
  2037.       end
  2038.     fun add_time (TIME{sec=s0,usec=u0},TIME{sec=s1,usec=u1}) =
  2039.       let val (s,u) = (s0+s1,u0+u1)
  2040.           val (s,u) = if u > 1000000 then (s+1,u-1000000)
  2041.               else (s,u)
  2042.       in  TIME{sec=s,usec=u}
  2043.       end
  2044.     fun earlier (TIME{sec=s1,usec=u1}, TIME{sec=s2,usec=u2}) = (
  2045.       (s1 < s2) orelse (ieql(s1, s2) andalso (u1 < u2)))
  2046.   end (* structure Timer *)
  2047.  
  2048.   structure Stats : STATS = 
  2049.   struct
  2050.     open Timer Ref PreStats Control.Runtime PreString
  2051.     fun update(a,b) = if earlier(zerotime,b)
  2052.              then a := add_time(!a, b) else ()
  2053.     fun summary() =
  2054.       let val pr = IO.outputc IO.std_out
  2055.           fun prTime t = (pr(makestring t); pr "s\n")
  2056.           val Timer{usr=total,sys=system,gc=garbagetime} = timer()
  2057.       in  pr (imakestring(!lines));
  2058.           pr " lines\n";
  2059.           pr "parse      "; prTime(!parse);
  2060.           if !Control.Debug.debugging then
  2061.         (pr "dbginstrum "; prTime(!debuginstrum))
  2062.           else ();
  2063.           pr "translate  "; prTime(!translate);
  2064.           pr "codeopt    "; prTime(!codeopt);
  2065.           pr "convert    "; prTime(!convert);
  2066.           pr "cpsopt     "; prTime(!cpsopt);
  2067.           pr "closure    "; prTime(!closure);
  2068.           pr "globalfix  "; prTime(!globalfix);
  2069.           pr "spill      "; prTime(!spill);
  2070.           pr "codegen    "; prTime(!codegen);
  2071.           pr "schedule   "; prTime(!schedule);
  2072.           pr "freemap    "; prTime(!freemap);
  2073.           pr "execution  "; prTime(!execution);
  2074.           pr "GC time    "; prTime garbagetime;
  2075.           pr "total(usr) "; prTime total;
  2076.           pr "total(sys) "; prTime system;
  2077.           pr "collections: "; pr(imakestring(!minorcollections));
  2078.           pr " minor, "; pr(imakestring(!majorcollections));
  2079.           pr " major\n"; pr(imakestring(!collected));
  2080.           pr " collected from "; pr(imakestring(!collectedfrom));
  2081.           pr " possible (";
  2082.           case (!collectedfrom)
  2083.            of 0 => ()
  2084.         | _ => pr(imakestring(InLine.div(InLine.*(!collected,100),
  2085.                     !collectedfrom)));
  2086.           pr "%)\n";
  2087.           pr "code bytes: "; pr(imakestring(!codesize)); pr "\n";
  2088.           ()
  2089.       end
  2090.     structure Timer : TIMER = Timer 
  2091.   end (* structure Stats *)
  2092.  
  2093.   structure Timer : TIMER = Stats.Timer
  2094.   structure Signals : SIGNALS = Signals
  2095.  
  2096.   structure Unsafe : UNSAFE =
  2097.   struct
  2098.     structure Assembly : ASSEMBLY = Assembly
  2099.     structure CInterface : CINTERFACE = CInterface
  2100.     structure SysIO : SYSIO = SysIO
  2101.     structure CleanUp : CLEANUP = CleanUp
  2102.     structure Weak : WEAK = Weak
  2103.     structure Susp : SUSP = Susp
  2104.     structure PolyCont : POLY_CONT = PolyCont
  2105.     type object = Assembly.object
  2106.     type instream = IO.instream
  2107.     type outstream = IO.outstream
  2108.     val boxed = InLine.cast()
  2109.     val unboxed = InLine.cast()
  2110.     val ordof = InLine.cast()
  2111.     val slength = InLine.cast()
  2112.     val objLength = InLine.cast()
  2113.     val getObjTag = InLine.cast()
  2114.     val special = InLine.cast()
  2115.     val setSpecial = InLine.cast()
  2116.     val getSpecial = InLine.cast()
  2117.     val store = InLine.cast()
  2118.     val bstore = InLine.cast()
  2119.     val subscript = InLine.cast()
  2120.     val update = InLine.cast()
  2121.     val subscriptv = InLine.cast()
  2122.     val subscriptf = InLine.cast()
  2123.     val updatef = InLine.cast()
  2124.     val getvar = InLine.cast()
  2125.     val setvar = InLine.cast()
  2126.     val gethdlr = InLine.cast()
  2127.     val sethdlr = InLine.cast()
  2128. (******
  2129.     fun boot (x : 'a) : 'b -> 'c = 
  2130.     (* adjust the pointer to skip the first word (which is a back-pointer) *)
  2131.       InLine.cast(InLine.+(InLine.cast x, 2),0)
  2132. ******)
  2133.     val cast = InLine.cast
  2134.     val blast_write = cast PreIO.blast_write
  2135.     val blast_read = cast PreIO.blast_read
  2136.     val create_s = Assembly.A.create_s
  2137.     val create_b = Assembly.A.create_b
  2138.     val store_s : string * int * int -> unit = InLine.cast ByteArray.update
  2139.     val lookup_r = Hooks.lookup_r
  2140.     val lookup = fn i => case lookup_r of ref f => f i
  2141.  
  2142.     val pstruct = cast(ref {core = (), initial=(), math=()})
  2143.     local
  2144.     datatype A = unboxed | boxed of object
  2145.     val cast = InLine.cast
  2146.     in  exception Boxity
  2147.     val tuple : object -> object vector
  2148.             = cast(fn unboxed => raise Boxity
  2149.                 | x as boxed _ => x)
  2150.     val string : object -> string = cast (fn x=>x)
  2151.     val real : object -> real = cast (fn x=>x)
  2152.     val int : object -> int
  2153.             = cast(fn x as unboxed => x
  2154.                 | boxed _ => raise Boxity)
  2155.     end (* local datatype A ... *)
  2156.     structure AA : sig
  2157.       datatype datalist
  2158.     = DATANIL
  2159.     | DATACONS of (string * (unit -> unit) * datalist)
  2160.       val datalist : datalist
  2161.     end = Assembly
  2162.     open AA
  2163.     val toplevelcont= Hooks.toplevelcont
  2164.  
  2165.     val profiling = ref false
  2166.     val sprofiling = ref false
  2167.   end (* Unsafe *)
  2168.  
  2169.   structure Directory : DIRECTORY =
  2170.   struct
  2171.     local open CInterface SysIO List String
  2172.     in
  2173.  
  2174.     fun isDir path =
  2175.       (case ftype(PATH path) of F_DIR => true | _ => false)
  2176.         handle (SystemCall _) => false
  2177.  
  2178.     exception NotDirectory
  2179.  
  2180.     fun listDir path = let
  2181.       val fd = openf (path, O_READ)
  2182.       fun f l = (case (getdirent fd) of [] => l | l' => f(l' @ l))
  2183.       val dirlist = rev (f [])
  2184.       in
  2185.         closef fd; dirlist
  2186.       end
  2187.         handle (SystemCall _) => raise NotDirectory
  2188.  
  2189.     fun cd s = (chdir s) handle (SysError _) => raise NotDirectory
  2190.  
  2191.     fun getWD () = let
  2192.       val root_id = getfid (PATH "/")
  2193.       fun walk_up (path, curdir) = let
  2194.         val curid = getfid(PATH curdir)
  2195.         in
  2196.           if (stringequal(curid, root_id))
  2197.             then (case path of [] => "/" | _ => implode path)
  2198.             else let
  2199.               val nextdir = curdir ^ "../"
  2200. (* NOTE: this code could be optimized by examining the directory entries incrementally *)
  2201.               fun scanDir nil = raise NotDirectory
  2202.             | scanDir (f::r) = let
  2203.                 val fid = getfid(PATH(nextdir ^ f))
  2204.                 in
  2205.                   if (stringequal(fid, curid)) then f else (scanDir r)
  2206.                 end
  2207.               val next = scanDir(listDir nextdir)
  2208.               in
  2209.             walk_up ("/" :: next :: path, nextdir)
  2210.               end
  2211.         end
  2212.       in
  2213.         walk_up ([], "./")
  2214.       end
  2215.     end (* local *)
  2216.   end (* Directory *)
  2217.  
  2218.   open PreLim
  2219.   val version = "Standard ML of New Jersey, Version 0.93, February 15, 1993"
  2220.   val architecture = ref ""
  2221.   val runtimeStamp = ref ""
  2222.   local open CInterface in
  2223.   val system = wrap_sysfn "system" (fn x => system (c_string x))
  2224.   end
  2225.  
  2226.   val argv = CInterface.argv
  2227.   val environ = CInterface.environ
  2228.   val errorMatch =  Core.errorMatch
  2229.  
  2230. end (* structure System *)
  2231.  
  2232. in
  2233. structure System : SYSTEM = System
  2234. structure List : LIST = List
  2235. structure IO : IO = IO
  2236. structure Bool : BOOL = Bool
  2237. structure String = String
  2238. structure ByteArray = ByteArray
  2239. end  (* local *)
  2240.  
  2241. open PrimTypes
  2242.  
  2243. (* The following structures must be without signatures so that inlining 
  2244.    can take place *)
  2245.  
  2246. structure General =
  2247.   struct
  2248.     infix 3 o
  2249.     infix before
  2250.     exception Bind = Core.Bind
  2251.     exception Match = Core.Match
  2252.     exception Interrupt
  2253.     exception Fail of string
  2254.  
  2255.     val callcc : ('1a cont -> '1a) -> '1a = InLine.callcc
  2256.     val throw : 'a cont -> 'a -> 'b = InLine.throw
  2257.  
  2258.     val use = System.Compile.use
  2259.  
  2260.     fun f o g = fn x => f(g x)
  2261.     fun a before b = a
  2262.     (*** datatype 'a option = NONE | SOME of 'a ***) (* moved to Bool *)
  2263.     type 'a cont = 'a cont
  2264.     type exn = exn
  2265.     type unit = unit
  2266.     infix 4 = <>
  2267.     val op = : ''a * ''a -> bool  = InLine.=
  2268.     val op <> : ''a * ''a -> bool = InLine.<>
  2269.  
  2270.     datatype 'a frag = QUOTE of string | ANTIQUOTE of 'a  
  2271.  
  2272.   end (* structure General *)
  2273.  
  2274. structure Bits =
  2275.   struct
  2276.     val andb : int * int -> int = InLine.andb
  2277.     val orb : int * int -> int = InLine.orb
  2278.     val lshift : int * int -> int = InLine.lshift
  2279.     val rshift : int * int -> int = InLine.rshift
  2280.     val notb : int -> int = InLine.notb
  2281.     val xorb : int * int -> int = InLine.xorb
  2282.   end
  2283.  
  2284. structure Ref = 
  2285.   struct
  2286.     infix 3 :=
  2287.     val ! : 'a ref -> 'a = InLine.!
  2288.     val op := : 'a ref * 'a -> unit = InLine.:=
  2289.     fun inc r = r := (InLine.+ : int * int -> int) (!r,1)
  2290.     fun dec r = r := (InLine.- : int * int -> int) (!r,1)
  2291.   end
  2292.  
  2293. structure Vector =
  2294. struct
  2295.  local open InLine in
  2296.   exception Size = ByteArray.Size
  2297.   exception Subscript = Core.Subscript
  2298.   type 'a vector = 'a vector
  2299.   val length : 'a vector -> int = length
  2300.   val sub : 'a vector * int -> 'a = 
  2301.       fn (a,i) => if lessu(i, length a) then subscriptv(a, i)
  2302.           else raise Subscript
  2303.   local
  2304.       val vector_n : int * 'a list -> 'a vector = 
  2305.       fn (n,al) => if n<=0 then if n<0 then raise Size 
  2306.                        else Core.Assembly.vector0
  2307.                else Core.Assembly.A.create_v(n,al)
  2308.   in
  2309.       fun tabulate(n,f) = 
  2310.       let fun tab j = if j<n then f j :: tab (j+1) else nil
  2311.       in vector_n(n,tab 0)
  2312.       end
  2313.       val vector:'a list -> 'a vector = fn al => vector_n(List.length al,al)
  2314.   end
  2315.  end
  2316. end  (* Vector *)
  2317.  
  2318. structure Array =
  2319. struct
  2320.  local open InLine in
  2321.   type 'a array = 'a array
  2322.   exception Subscript = Vector.Subscript
  2323.   exception Size = Vector.Size
  2324.   val array : int * '1a -> '1a array =
  2325.     fn arg as (n,v) =>
  2326.        if gequ(n,System.Tags.max_length) (* catch negative-length arrays,
  2327.                                and arrays with a size too big 
  2328.                            to fit in the descriptor *)
  2329.           then raise Size
  2330.       else if ieql(n,0) then Core.Assembly.array0
  2331.            else Core.Assembly.A.array arg
  2332.   val sub : 'a array * int -> 'a = InLine.inlsubscript
  2333.   val length : 'a array -> int = InLine.length
  2334.   fun arrayoflist nil = Core.Assembly.array0
  2335.     | arrayoflist (l as (e::r)) =
  2336.     let val a = array(List.length l, e)
  2337.         fun init ((e::r),n) = (update(a,n,e); init(r,n+1))
  2338.           | init (nil,_) = ()
  2339.     in  init(r,1); a
  2340.     end
  2341.   val update : 'a array * int * 'a -> unit = InLine.inlupdate
  2342.   val tabulate : int*(int -> '1a) -> '1a array = fn (i,f) =>
  2343.       let fun tab j = if j<i then f j :: tab(j+1) else nil
  2344.       in if i<0 then raise Size else arrayoflist (tab 0)
  2345.       end
  2346.  end (* local open ... *)
  2347. end (* structure Array *)
  2348.  
  2349. structure RealArray =
  2350. struct
  2351.  local open InLine in
  2352.   infix 9 sub  
  2353.   exception RealSubscript = Core.RealSubscript
  2354.   exception Size
  2355.   type realarray = Core.Assembly.A.realarray
  2356.   val length : realarray -> int = InLine.length
  2357.   fun array (n : int, v : real) =
  2358.       if gequ(n,System.Tags.max_length) (* catch negative-length arrays, and 
  2359.                        arrays with a size too big to fit
  2360.                                            in the descriptor *)
  2361.       then (if n<0 then raise Size else Core.Assembly.realarray0)
  2362.       else let val a = Core.Assembly.A.create_r n
  2363.            fun init i = if ieql(i,n) then ()
  2364.                 else (updatef(a,i,v); init (i+1))
  2365.         in init 0; a
  2366.        end
  2367.   val op sub : realarray * int -> real = inlsubscriptf
  2368.   val op update : realarray * int * real -> unit = inlupdatef
  2369.  end  (* local *)
  2370. end  (* RealArray *)
  2371.  
  2372. structure Integer =
  2373. struct
  2374.   infix 7 * div mod quot rem
  2375.   infix 6 + -
  2376.   infix 4 > < >= <=
  2377.   exception Div = Core.Assembly.Div
  2378.   exception Mod = Div
  2379.   exception Overflow = Core.Assembly.Overflow
  2380.   exception Sum=Overflow and Diff=Overflow and Quot=Overflow and Abs=Overflow
  2381.     and Prod=Overflow and Neg=Overflow
  2382.   type int = int
  2383.   val ~ : int -> int = InLine.~
  2384.   val op * : int * int -> int = InLine.*
  2385.   val op + : int * int -> int = InLine.+
  2386.   val op - : int * int -> int = InLine.-
  2387.   val op > : int * int -> bool = InLine.>
  2388.   val op >= : int * int -> bool = InLine.>=
  2389.   val op < : int * int -> bool = InLine.<
  2390.   val op <= : int * int -> bool = InLine.<=
  2391.   fun op div(a:int,b:int):int =
  2392.       if b>=0
  2393.       then if a>=0 then InLine.div(a,b)
  2394.                else InLine.div(a+1,b)-1
  2395.       else if a>0  then InLine.div(a-1,b)-1
  2396.                else InLine.div(a,b)
  2397.    fun op mod(a:int,b:int):int =
  2398.       if b>=0
  2399.       then if a>=0 then a-InLine.div(a,b)*b
  2400.                else a-InLine.div(a+1,b)*b+b
  2401.       else if a>0  then a-InLine.div(a-1,b)*b+b
  2402.                else if InLine.ieql(a,~1073741824)
  2403.                    andalso InLine.ieql(b,~1) then 0
  2404.                   else a-InLine.div(a,b)*b
  2405.   val op quot : int * int -> int = InLine.div
  2406.   fun op rem(a:int,b:int):int = a-(a quot b)*b
  2407.   fun min(a,b) = if a<b then a else b
  2408.   fun max(a,b) = if a>b then a else b
  2409.   fun abs a = if a<0 then ~a else a
  2410.   fun makestring i =
  2411.     if i<0 then (String.^("~", makestring(~i))
  2412.               handle Overflow => "~1073741824")
  2413.     else if i<10 then InLine.cast(InLine.cast "0" + i)
  2414.     else let val j = i quot 10
  2415.          in  String.^(makestring j, makestring(i-j*10))
  2416.          end
  2417.   local val pr = IO.outputc IO.std_out in
  2418.   fun print i = pr(makestring i)
  2419.   end
  2420. end  (* structure Integer *)
  2421.  
  2422. structure Real =
  2423. struct
  2424.  local 
  2425.   open Math String
  2426.   val negone = ~1.0
  2427.   val zero = 0.0
  2428.   val half = 0.5
  2429.   val one = 1.0
  2430.   val two = 2.0
  2431.   val five = 5.0
  2432.   val ten = 10.0
  2433.  in
  2434.   infix 7 * /
  2435.   infix 6 + -
  2436.   infix 4 > < >= <=
  2437.   type real = real
  2438.   exception Div=Integer.Div
  2439.   exception Overflow=Integer.Overflow
  2440.   exception Sum=Overflow and Diff=Overflow and Prod=Overflow
  2441.   and Exp=Overflow and Floor=Overflow
  2442.   val ~ : real -> real = InLine.fnegd
  2443.   val op + : real * real -> real = InLine.fadd
  2444.   val op - : real * real -> real = InLine.fsub
  2445.   val op * : real * real -> real = InLine.fmul
  2446.   val op / : real * real -> real = InLine.fdiv
  2447.   val op > : real * real -> bool = InLine.fgt
  2448.   val op < : real * real -> bool = InLine.flt
  2449.   val op >= : real * real -> bool = InLine.fge
  2450.   val op <= : real * real -> bool = InLine.fle
  2451.   val sin = sin and cos = cos and sqrt = sqrt and arctan = arctan
  2452.   and exp = exp and ln = ln
  2453.   exception Sqrt = Sqrt and Ln = Ln
  2454.  
  2455.   val floor = Core.Assembly.A.floor
  2456.   fun realfloor (_:real) : real = 
  2457.       let exception Unimplemented_realfloor 
  2458.       in
  2459.       raise Unimplemented_realfloor 
  2460.       end
  2461.   fun truncate n = if n < 0.0 then Integer.~(floor(~n)) else floor n
  2462.   fun ceiling n = Integer.~(floor(~n))
  2463.  
  2464.  
  2465.   val abs : real -> real = InLine.fabsd
  2466.   val real : int -> real = InLine.real
  2467.   fun makestring r =
  2468.     let val itoa = Integer.makestring
  2469.         fun scistr(a::b::tl,e) =
  2470.           let fun trail nil = ""
  2471.             | trail (0::tl) =
  2472.               let val rest = trail tl
  2473.               in  case rest of "" => ""
  2474.                      | _ => "0"^rest
  2475.               end
  2476.             | trail (hd::tl) = itoa hd ^ trail tl
  2477.               val rest = trail tl
  2478.           in  itoa a ^ "." ^ itoa b ^ rest ^ "E" ^ itoa e
  2479.           end
  2480.           | scistr _ = "" (* prevents non-exhaustive match *)
  2481.         fun normstr(digits,e) =
  2482.           let fun n(nil,_) = ""
  2483.             | n(hd::nil,0) = itoa hd ^ ".0"
  2484.             | n(hd::tl,0) = itoa hd ^ "." ^ n(tl,~1)
  2485.             | n(0::tl,d) =
  2486.                 let val rest = n(tl,InLine.-(d,1))
  2487.                 in  case (InLine.<(d,~1),rest) of
  2488.                   (true,"") => rest
  2489.                   | _ => "0" ^ rest
  2490.                 end
  2491.             | n(hd::tl,d) = itoa hd ^ n(tl,InLine.-(d,1))
  2492.               fun header n =
  2493.             let fun zeros 1 = ""
  2494.                   | zeros n = "0" ^ zeros(InLine.-(n,1))
  2495.             in  "0." ^ zeros n
  2496.             end
  2497.           in  if InLine.<(e,0)
  2498.               then header(InLine.~ e) ^ n(digits,e)
  2499.               else n(digits,e)
  2500.           end
  2501.         fun mkdigits(f,0) = (nil,if f < five then 0 else 1)
  2502.           | mkdigits(f,i) =
  2503.           let    val digit = floor f
  2504.               val new = ten * (f - real digit)
  2505.               val (digits,carry) = mkdigits(new,InLine.-(i,1))
  2506.               val (digit,carry) = case (digit,carry) of
  2507.                        (9,1) => (0,1)
  2508.                       | _ => (InLine.+(digit,carry),0)
  2509.           in  (digit::digits,carry)
  2510.           end
  2511.         (* should eventually speed this up by using log10 *)
  2512.         fun mkstr(f,e) =
  2513.         if f >= ten then mkstr(f/ten,InLine.+(e,1))
  2514.         else if f < one then mkstr(f*ten,InLine.-(e,1))
  2515.         else let val (digits,carry) = mkdigits(f,15)
  2516.              val (digits,e) = case carry of
  2517.                         0 => (digits,e)
  2518.                       | _ => (1::digits,InLine.+(e,1))
  2519.              in  if InLine.>(e,~5) andalso InLine.<(e,15)
  2520.              then normstr(digits,e)
  2521.              else scistr(digits,e)
  2522.              end
  2523.     in  if r < zero then "~" ^ mkstr(~r,0)
  2524.         else if InLine.feql(r,zero) then "0.0"
  2525.         else mkstr(r,0)
  2526.     end (* fun makestring *)
  2527.   local
  2528.     val pr = IO.outputc IO.std_out
  2529.   in
  2530.     fun print r = pr(makestring r)
  2531.   end
  2532.  end (* local *)
  2533. end (* structure Real *)
  2534.  
  2535. structure System =
  2536. struct
  2537.   open System
  2538.  
  2539.   structure Unsafe =
  2540.   struct
  2541.     open Unsafe
  2542.  
  2543.     structure PolyCont =
  2544.     struct
  2545.       open PolyCont
  2546.       val callcc : ('a cont -> 'a) -> 'a = InLine.callcc
  2547.       val throw : 'a cont -> 'a -> 'b = InLine.throw
  2548.       val capture : ('a control_cont -> 'a) -> 'a = InLine.capture
  2549.       val escape : 'a control_cont -> 'a -> 'b = InLine.throw
  2550.     end
  2551.  
  2552.     val cast : 'a -> 'b = InLine.cast
  2553.     val boxed : 'a -> bool = InLine.boxed
  2554.     val ordof : string * int -> int = InLine.ordof
  2555.     val slength : string -> int = InLine.length
  2556.     val objLength : 'a -> int = InLine.objlength
  2557.     val getObjTag : 'a -> int = InLine.gettag
  2558.     val special : (int * 'a) -> 'b = InLine.mkspecial
  2559.     val setSpecial : ('a * int) -> unit = InLine.setspecial
  2560.     val getSpecial : 'a -> int = InLine.getspecial
  2561.     val store : string * int * int -> unit = InLine.store
  2562.     val bstore : Assembly.A.bytearray * int * int -> unit = InLine.store
  2563.     val subscript : 'a array * int -> 'a = InLine.subscript
  2564.     val subscriptv : 'a vector * int -> 'a = InLine.subscriptv
  2565.     val subscriptf : Assembly.A.realarray * int -> real = InLine.subscriptf
  2566.     val updatef : Assembly.A.realarray * int * real -> unit = InLine.updatef
  2567.     val update : 'a array * int * 'a -> unit = InLine.update
  2568.     val getvar : unit -> 'a = InLine.getvar
  2569.     val setvar : 'a -> unit = InLine.setvar
  2570.     val gethdlr : unit -> 'a = InLine.gethdlr
  2571.     val sethdlr : 'a -> unit = InLine.sethdlr
  2572.   end  (* Unsafe *)
  2573.  
  2574.   val argv = Unsafe.CInterface.argv
  2575.   val environ = Unsafe.CInterface.environ
  2576. end (* System *)
  2577.     
  2578. open Ref String IO Bool List Integer Real General
  2579.  
  2580. (* Install some default signal handlers *)
  2581. local
  2582.   open System.Signals
  2583.   fun quit s _ = let val msg = (s ^ " (no coredump)\n\000")
  2584.     in
  2585.     (* use write, since IO.output will block if we've lost the ptty *)
  2586.       System.Unsafe.SysIO.write(2, System.Unsafe.cast msg, size msg)
  2587.         handle _ => ();
  2588.       System.Unsafe.CleanUp.shutdown()
  2589.     end
  2590. in
  2591.   val _ = setHandler(SIGHUP, SOME(quit "\nHangup"))
  2592.   val _ = setHandler(SIGINT, SOME(fn _ => !System.Unsafe.toplevelcont))
  2593.   val _ = setHandler(SIGQUIT, SOME(quit "\nQuit"))
  2594.   val _ = setHandler(SIGTERM, SOME(quit "\nSoftware termination"))
  2595. end (* local *)
  2596.  
  2597. val _ = IO.outputc IO.std_out "Initial done\n"
  2598.  
  2599. end (* structure Initial *)
  2600.